home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / fortran / toolpack.000 / toolpack / toolpack1.2 / tools / istsa / SALIB.MAC.f < prev   
Encoding:
Text File  |  1993-10-04  |  126.1 KB  |  3,997 lines
  1. C YXLIB Customisation Parameters
  2. C ------------------------------
  3.  
  4. C Routine Names
  5. C -------------
  6.  
  7. C Field Definitions: Parse Tree Attributes
  8. C ----------------------------------------
  9. C Note: The high-order bit in the word (bit 31 in a 32-bit machine) MUST
  10. C       NOT BE USED, as ordinary arithmetic is used to extract some fields
  11.  
  12. C Attribute Table Macros
  13. C ----------------------
  14.  
  15. C YXLIB Bits
  16. C ----------
  17.  
  18. C YXLIB Local Record Macros
  19. C -------------------------
  20. C   type VARX = record
  21. C                   su: integer;    (* Storage units for variable *)
  22. C                   common: ^(S_COMMON) or -maxint..-1;
  23. C                                   (* ^(common block symbol), nil (0) or
  24. C                                      negative of equivalence class number *)
  25. C                   comsize: integer;(* Offset in common or equiv class *)
  26. C                   equiv: ^EQV;    (* Pointer to equivalence link *)
  27. C                   if SYMBOL(var_arr_decl)<>0 then array: ARRAYX
  28. C                                   (* array information stored here *)
  29. C               end;
  30. C
  31. C   type ARRAYX = record
  32. C                   elts: integer;  (* Number of elements in the array *)
  33. C                   dims: integer;  (* Number of dimensions of the array *)
  34. C                   limits: array [1..dims] of
  35. C                               record LOWER,UPPER: integer end
  36. C                 end;
  37.  
  38.  
  39. C   type EQH = HEAD record          (* Equivalence head record *)
  40. C                       common: ^(S_COMMON) or -maxint..-1;
  41. C                       usage: set of usage_bits
  42. C                   end;
  43.  
  44. C   type EQV = LINK record          (* Equivalence variable record (link) *)
  45. C                       sudif: integer;
  46. C                       symbol: ^(S_VAR)
  47. C                   end;
  48.  
  49. C   type LPR = record
  50. C                   glob: ^(GPU) or -^(GEX);
  51. C                   nargs: integer;
  52. C                   args: array [1..nargs] of packed record
  53. C                               dtype: min_dtype..max_dtype;
  54. C                               argument_type: atype;
  55. C                               descendents: ^HEAD;
  56. C                               if dtype=type_char then
  57. C                                   min_length, max_length: integer
  58. C                               end if
  59. C                           end record
  60. C              end;
  61.  
  62. C                                   (* Argument type definitions *)
  63. C   type ATYPE = (scalar,arelm,array,proc,label);
  64. C   const min_atype = scalar; max_atype = label;
  65.  
  66. C YXLIB Record Definition: Semi-Local
  67. C -----------------------------------
  68. C   type PAREC = LINK record
  69. C                   argnum: integer; (* Argument number passed down as *)
  70. C                   prsym: ^(S_PROC); (* Procedure passed down to *)
  71. C                   argsym: ^symbol; (* Actual argument being passed down *)
  72. C                   pusym: ^(S_PU); (* Associating program-unit (context) *)
  73. C                   stmtno: integer; (* Statement number of assoc (context) *)
  74. C                end;
  75.  
  76. C   type UNSAF = LINK record
  77. C                   code: 1..5;     (* Type of unsafe reference to be checked *)
  78. C                   argnum: integer;(* Argument number applicable *)
  79. C                   extra: anything;(* Extra data (not used by inherit_expr) *)
  80. C                   pusym: ^(S_PU); (* Context: associating program-unit *)
  81. C                   stmtno: integer;(* Context: statement number *)
  82. C                   prsym: ^(S_PROC)(* proc being called *)
  83. C                end;
  84.  
  85. C YXLIB Global Record Macros
  86. C --------------------------
  87. C
  88. C   type G_COM = record             Global common block record
  89. C                   size: integer;
  90. C                   type: (character,numeric,mixed); (* logical = numeric *)
  91. C                   save: (saved,not_saved,only_in_main);
  92. C                   init: integer   (* Number of times init'ed by block data *)
  93. C                end;
  94.  
  95. C
  96. C   type G_PU = record              Global program-unit record
  97. C                   dtype: integer;
  98. C                   chrlen: integer;
  99. C                   culist: ^HEAD;  (* common block usage list header ptr *)
  100. C                   nargs: integer;
  101. C                   descend: ^HEAD; (* descendent routine list header ptr *)
  102. C                   entrys: ^(HEAD) record ^G_ENT end;
  103. C                   args: array [1..nargs] of gpuarg
  104. C               end;
  105.  
  106. C   type G_ENT = record
  107. C                   dtype: integer;
  108. C                   chrlen: integer;
  109. C                   pu: ^G_PU;
  110. C                   nargs: integer;
  111. C                   descend: ^HEAD; (* descendent routine list header ptr *)
  112. C                   args: array [1..nargs] of ^guparg
  113. C                end;
  114.  
  115. C type gpuarg = record
  116. C                   dtype,chlen: integer;
  117. C                   usage: (arg,read,update);
  118. C                   struc: (scal,array,proc,label);
  119. C                   size: integer;
  120. C                   pass: ^HEAD;
  121. C                   inh: ^HEAD(inherit)
  122. C               end;
  123. C type inherit = record
  124. C                   type: (proc,expr,dupl,comm,sfa,doix,arg);
  125. C                   ass: ^(GPU);    (* associating program-unit *)
  126. C                   snum: integer;  (* statement number of association *)
  127. C                   if (type=proc) then
  128. C                       gsyptr: ^(GPU)/-^(GEX)
  129. C                   else
  130. C                       extra: integer (* unsafe ref extra data *)
  131. C                   end if
  132.  
  133.  
  134. C Global Descendant Routine Types
  135. C -------------------------------
  136.  
  137. C Error Codes returned by YXLIB
  138. C -----------------------------
  139. C
  140. C Additional definitions for ISTSA
  141. C
  142.  
  143.  
  144.  
  145.  
  146.  
  147.  
  148.  
  149.  
  150. C                                   parameter length
  151.  
  152.  
  153.  
  154.  
  155.  
  156.  
  157.  
  158. C ----------------------------------------------------------------------
  159. C
  160. C       A N A L Y S   -   Analyse the program stored in the parse tree
  161. C
  162.  
  163.         SUBROUTINE ANALYS(TRACE,ERRORS,WARNS)
  164.         LOGICAL TRACE
  165.         INTEGER ERRORS,WARNS
  166.  
  167.         COMMON/ERRORC/NERROR,NWARN
  168.         INTEGER NERROR,NWARN
  169.  
  170.         COMMON/CONTXT/PUN,STMTNO
  171.         INTEGER PUN,STMTNO
  172.  
  173.         COMMON/PUNAMC/PUNAME
  174.         CHARACTER*6 PUNAME
  175.  
  176.         INTEGER PTR,NMAINS
  177.         LOGICAL MAIN
  178.  
  179.         SAVE /CONTXT/,/PUNAMC/,/ERRORC/
  180.  
  181.         INTEGER LENSTR
  182.  
  183.         INTEGER ZYROOT,ZYNEXT,ZYDOWN,ZYNTYP
  184.         EXTERNAL ZYROOT,ZYNEXT,ZYDOWN,ZYNTYP,ZMESS
  185.  
  186.         PTR=ZYDOWN(ZYROOT())
  187.         PUN=1
  188.         NMAINS=0
  189.         NERROR=ERRORS
  190.         NWARN=WARNS
  191.  
  192.  100    MAIN=ZYNTYP(PTR).EQ.2
  193.         IF (MAIN) NMAINS=NMAINS+1
  194.         CALL PASS1(PTR,MAIN)
  195.         PTR=ZYNEXT(PTR)
  196.         PUN=PUN+1
  197.         IF (TRACE)
  198.      +      CALL ZMESS('['//PUNAME(:LENSTR(PUNAME))//' processed]',
  199.      +                 1)
  200.         IF (PTR.NE.0) GOTO 100
  201.         IF (NERROR.EQ.0) THEN
  202.             IF (NMAINS.GT.1)
  203.      +          CALL ERRMES('More than one main program',-1)
  204.             CALL PASS4
  205.             IF (TRACE)
  206.      +          CALL ZMESS('[Global processing completed]',1)
  207.         ELSE IF (TRACE) THEN
  208.             CALL ZMESS('[No global processing]',1)
  209.         END IF
  210.         ERRORS=NERROR
  211.         WARNS=NWARN
  212.  
  213.         END
  214. C ----------------------------------------------------------------------
  215. C
  216. C       P A S S 1   -   Process a single program-unit, pass 1
  217. C
  218.  
  219.         SUBROUTINE PASS1(PUROOT,MAIN)
  220.         INTEGER PUROOT
  221.         LOGICAL MAIN
  222.  
  223.         INTEGER MAXNTY
  224.         PARAMETER (MAXNTY=132)
  225.  
  226.         COMMON/ERRORC/NERROR,NWARN
  227.         INTEGER NERROR,NWARN
  228.  
  229.         COMMON/CONTXT/PUN,STMTNO
  230.         INTEGER PUN,STMTNO
  231.  
  232.         COMMON/PUNAMC/PUNAME
  233.         CHARACTER*6 PUNAME
  234.  
  235.         COMMON/DOSTK/DOLVL,DOLBL,DOIDX
  236.         INTEGER DOLVL,DOLBL(25),DOIDX(25)
  237.  
  238.         INTEGER PTR,NTYPE,P2,TEXT(134),SYMBOL(8),STATUS,I,
  239.      +          SEQIN(MAXNTY),SEQOUT(MAXNTY),SEQ,TMP,LABEL,NTYPE2,
  240.      +          ERRCNT,SAVSNO
  241.         LOGICAL BLKDTA,SEQOK,LABLED
  242.  
  243.         SAVE /CONTXT/,/PUNAMC/,/DOSTK/,/ERRORC/,SEQIN,SEQOUT
  244.  
  245.         INTEGER ZYDOWN,ZYNEXT,ZYNTYP,ZYUP,CTOI,ZYXGVA
  246.         EXTERNAL ZYDOWN,ZYNEXT,ZYNTYP,ZYUP,ZYGTSY,ZYGTST,ZITOF,CTOI,
  247.      +           ZYXSVA,ZYXGVA,ZYXCEQ,ERRSYM
  248.  
  249. C Statement sequence processing:
  250. C   SEQ = current position in sequence
  251. C   SEQIN(node type) = maximum position at which this node type can occur
  252. C   SEQOUT(node type) = minimum position implied by this node
  253. C   SEQOK = statement sequence ok so far (so we only output the one error
  254. C           message)
  255. C
  256. C   Sequence Position Numbers: 0 = P.U. header stmt (enforced by ISTYP)
  257. C                              1 = FORMAT/ENTRY/PARAMETER/IMPLICIT
  258. C                              2 = FORMAT/ENTRY/PARAMETER/other specs
  259. C                              3 = FORMAT/ENTRY/DATA/statement functions
  260. C                              4 = FORMAT/ENTRY/DATA/executables
  261. C                              5 = END statement (enforced by ISTYP)
  262.  
  263.         DATA SEQIN(6),SEQOUT(6)/4,5/
  264.         DATA SEQIN(7),SEQOUT(7)/0,1/
  265.         DATA SEQIN(8),SEQOUT(8)/0,1/
  266.         DATA SEQIN(16),SEQOUT(16)/0,1/
  267.         DATA SEQIN(18),SEQOUT(18)/4,1/
  268.         DATA SEQIN(19),SEQOUT(19)/0,1/
  269.         DATA SEQIN(20),SEQOUT(20)/2,2/
  270.         DATA SEQIN(24),SEQOUT(24)/2,2/
  271.         DATA SEQIN(26),SEQOUT(26)/2,2/
  272.         DATA SEQIN(30),SEQOUT(30)/2,2/
  273.         DATA SEQIN(32),SEQOUT(32)/1,1/
  274.         DATA SEQIN(35),SEQOUT(35)/2,1/
  275.         DATA SEQIN(37),SEQOUT(37)/2,2/
  276.         DATA SEQIN(38),SEQOUT(38)/2,2/
  277.         DATA SEQIN(39),SEQOUT(39)/2,2/
  278.         DATA SEQIN(41),SEQOUT(41)/4,3/
  279.         DATA SEQIN(49),SEQOUT(49)/4,4/
  280.         DATA SEQIN(50),SEQOUT(50)/4,4/
  281.         DATA SEQIN(51),SEQOUT(51)/4,4/
  282.         DATA SEQIN(52),SEQOUT(52)/4,4/
  283.         DATA SEQIN(53),SEQOUT(53)/4,4/
  284.         DATA SEQIN(55),SEQOUT(55)/4,4/
  285.         DATA SEQIN(56),SEQOUT(56)/4,4/
  286.         DATA SEQIN(57),SEQOUT(57)/4,4/
  287.         DATA SEQIN(58),SEQOUT(58)/4,4/
  288.         DATA SEQIN(59),SEQOUT(59)/4,4/
  289.         DATA SEQIN(60),SEQOUT(60)/4,4/
  290.         DATA SEQIN(61),SEQOUT(61)/4,4/
  291.         DATA SEQIN(62),SEQOUT(62)/4,4/
  292.         DATA SEQIN(63),SEQOUT(63)/4,4/
  293.         DATA SEQIN(64),SEQOUT(64)/4,4/
  294.         DATA SEQIN(65),SEQOUT(65)/4,4/
  295.         DATA SEQIN(66),SEQOUT(66)/4,4/
  296.         DATA SEQIN(67),SEQOUT(67)/4,4/
  297.         DATA SEQIN(72),SEQOUT(72)/4,4/
  298.         DATA SEQIN(73),SEQOUT(73)/4,4/
  299.         DATA SEQIN(74),SEQOUT(74)/4,4/
  300.         DATA SEQIN(75),SEQOUT(75)/4,4/
  301.         DATA SEQIN(76),SEQOUT(76)/4,4/
  302.         DATA SEQIN(77),SEQOUT(77)/4,4/
  303.         DATA SEQIN(78),SEQOUT(78)/4,1/
  304.         DATA SEQIN(82),SEQOUT(82)/4,4/
  305.         DATA SEQIN(83),SEQOUT(83)/4,4/
  306.         DATA SEQIN(121),SEQOUT(121)/3,3/
  307.  
  308.         BLKDTA=ZYNTYP(PUROOT).EQ.5
  309.         STMTNO=1
  310.         PTR=ZYDOWN(PUROOT)
  311.         SEQOK=.TRUE.
  312.         SEQ=0
  313.         DOLVL=0
  314.         IF (MAIN) PUNAME='$MAIN'
  315.         ERRCNT=NERROR
  316.  
  317.   99    NTYPE=ZYNTYP(PTR)
  318.         IF (NTYPE.EQ.8 .OR. NTYPE.EQ.16 .OR.
  319.      +           NTYPE.EQ.7 .OR. NTYPE.EQ.19) THEN
  320.             P2=ZYDOWN(PTR)
  321.             IF (P2.NE.0) THEN
  322.               IF (ZYNTYP(P2).NE.108) P2=ZYNEXT(P2)
  323.               IF (P2.NE.0) THEN
  324.                   CALL ZYGTSY(-ZYDOWN(P2),SYMBOL)
  325.                   CALL ZYGTST(SYMBOL(2),TEXT)
  326.                   CALL ZITOF(TEXT,1,6,PUNAME,.FALSE.)
  327.               ENDIF
  328.             ENDIF
  329.         ENDIF
  330.         IF (SEQIN(NTYPE).LT.SEQ .AND.SEQOK) THEN
  331.             CALL ERRMES('Statement out of sequence',-1)
  332.             SEQOK=.FALSE.
  333.         END IF
  334.         SEQ=MAX(SEQ,SEQOUT(NTYPE))
  335.         PTR=ZYNEXT(PTR)
  336.         STMTNO=STMTNO+1
  337.         IF (PTR.NE.0) GOTO 99
  338.         IF (NERROR.NE.ERRCNT) RETURN
  339.  
  340.         STMTNO=1
  341.         SEQ=0
  342.         PTR=ZYDOWN(PUROOT)
  343.  
  344.  100    NTYPE=ZYNTYP(PTR)
  345.         IF (SEQ.LE.2 .AND. SEQOUT(NTYPE).GT.2 .AND. NERROR.EQ.ERRCNT)
  346.      +  THEN
  347.             SAVSNO=STMTNO
  348.             STMTNO=0
  349.             CALL PASS2(PUN,MAIN)
  350.             IF (NERROR.EQ.ERRCNT) CALL PASS3(PUROOT,MAIN)
  351.             STMTNO=SAVSNO
  352.         END IF
  353.         SEQ=MAX(SEQ,SEQOUT(NTYPE))
  354.         P2=ZYDOWN(PTR)
  355.         LABLED=.FALSE.
  356.         IF (P2.NE.0) THEN
  357.             IF (ZYNTYP(P2).EQ.115) THEN
  358.                 LABLED=.TRUE.
  359.                 CALL ZYGTSY(-ZYDOWN(P2),SYMBOL)
  360.                 IF (MOD(SYMBOL(6),1000).GT.0 .AND.
  361.      +              (NTYPE.EQ.51 .OR. NTYPE.EQ.53 .OR.
  362.      +              NTYPE.EQ.55 .OR. NTYPE.EQ.57 .OR.
  363.      +              NTYPE.EQ.83 .OR. NTYPE.EQ.63 .OR.
  364.      +              NTYPE.EQ.61 .OR. NTYPE.EQ.6))
  365.      +              CALL ERRMES('Illegal ending statement for DO loop',
  366.      +                          -1)
  367. C If possible end-of-DO-loop, remember the label value
  368.                 IF (DOLVL.GT.0) THEN
  369.                     CALL ZYGTST(SYMBOL(2),TEXT)
  370.                     I=1
  371.                     LABEL=CTOI(TEXT,I)
  372.                 END IF
  373.                 P2=ZYNEXT(P2)
  374.             END IF
  375.         END IF
  376.         IF (NTYPE.EQ.49) THEN
  377.             IF (BLKDTA) CALL ERRMES('Invalid statement in BLOCK DATA',
  378.      +                              -1)
  379.             CALL PROASG(P2)
  380.         ELSE IF (NTYPE.EQ.61) THEN
  381.             IF (BLKDTA) CALL ERRMES('Invalid statement in BLOCK DATA',
  382.      +                              -1)
  383.             CALL PRODO(P2)
  384.         ELSE IF (NTYPE.EQ.57 .OR. NTYPE.EQ.58) THEN
  385.             IF (BLKDTA) CALL ERRMES('Invalid statement in BLOCK DATA',
  386.      +                              -1)
  387.             CALL PROBIF(P2)
  388.         ELSE IF (NTYPE.EQ.56) THEN
  389.             IF (BLKDTA) CALL ERRMES('Invalid statement in BLOCK DATA',
  390.      +                              -1)
  391.             CALL PROLIF(P2)
  392. C Always check out the conditional statement...
  393.             PTR=ZYNEXT(P2)
  394.             GOTO 100
  395.         ELSE IF (NTYPE.EQ.67) THEN
  396.             IF (BLKDTA) CALL ERRMES('Invalid statement in BLOCK DATA',
  397.      +                              -1)
  398.             CALL PROPRI(P2)
  399.         ELSE IF (NTYPE.EQ.66) THEN
  400.             IF (BLKDTA) CALL ERRMES('Invalid statement in BLOCK DATA',
  401.      +                              -1)
  402.             CALL PROREA(P2)
  403.         ELSE IF (NTYPE.EQ.65) THEN
  404.             IF (BLKDTA) CALL ERRMES('Invalid statement in BLOCK DATA',
  405.      +                              -1)
  406.             CALL PROWRI(P2)
  407.         ELSE IF (NTYPE.EQ.72 .OR. NTYPE.EQ.73 .OR.
  408.      +           NTYPE.EQ.74 .OR. NTYPE.EQ.77 .OR.
  409.      +           NTYPE.EQ.75 .OR. NTYPE.EQ.76) THEN
  410.             IF (BLKDTA) CALL ERRMES('Invalid statement in BLOCK DATA',
  411.      +                              -1)
  412.             CALL PROAUX(P2)
  413.         ELSE IF (NTYPE.EQ.53) THEN
  414.             IF (BLKDTA) CALL ERRMES('Invalid statement in BLOCK DATA',
  415.      +                              -1)
  416.             CALL PROGOA(P2)
  417.         ELSE IF (NTYPE.EQ.52) THEN
  418.             IF (BLKDTA) CALL ERRMES('Invalid statement in BLOCK DATA',
  419.      +                              -1)
  420.             CALL PROGOC(P2)
  421.         ELSE IF (NTYPE.EQ.35) THEN
  422.             CALL PROPAR(P2)
  423.         ELSE IF (NTYPE.EQ.30 .OR. NTYPE.EQ.20) THEN
  424.             CALL PROTYP(P2)
  425.         ELSE IF (NTYPE.EQ.26) THEN
  426.             CALL PROCOM(P2,BLKDTA)
  427.         ELSE IF (NTYPE.EQ.41) THEN
  428.             CALL PRODAT(P2,BLKDTA)
  429.         ELSE IF (NTYPE.EQ.121) THEN
  430.             IF (BLKDTA) CALL ERRMES('Invalid statement in BLOCK DATA',
  431.      +                              -1)
  432.             CALL PROSF(P2)
  433.         ELSE IF (NTYPE.EQ.50) THEN
  434.             IF (BLKDTA) CALL ERRMES('Invalid statement in BLOCK DATA',
  435.      +                              -1)
  436.             CALL PROASS(P2)
  437.         ELSE IF (NTYPE.EQ.37 .OR. NTYPE.EQ.38) THEN
  438.             IF (BLKDTA) CALL ERRMES('Invalid statement in BLOCK DATA',
  439.      +                              -1)
  440.         ELSE IF (NTYPE.EQ.82) THEN
  441.             IF (BLKDTA) CALL ERRMES('Invalid statement in BLOCK DATA',
  442.      +                              -1)
  443.             CALL PROCAL(P2)
  444.         ELSE IF (NTYPE.EQ.83) THEN
  445.             IF (ZYNTYP(PUROOT).EQ.2) THEN
  446.                 CALL ERRMES('RETURN invalid in main program',-1)
  447.             ELSE IF (BLKDTA) THEN
  448.                 CALL ERRMES('Invalid statement in BLOCK DATA',-1)
  449.             ELSE
  450.                 CALL PRORET(P2)
  451.             END IF
  452.         ELSE IF (NTYPE.EQ.55) THEN
  453.             IF (BLKDTA) CALL ERRMES('Invalid statement in BLOCK DATA',
  454.      +                              -1)
  455.             CALL PROAIF(P2)
  456.         ELSE IF (NTYPE.EQ.63 .OR. NTYPE.EQ.64) THEN
  457.             IF (BLKDTA) CALL ERRMES('Invalid statement in BLOCK DATA',
  458.      +                              -1)
  459.             CALL PROPAU(P2)
  460.         ELSE IF (NTYPE.EQ.8 .OR. NTYPE.EQ.16 .OR.
  461.      +           NTYPE.EQ.7 .OR. NTYPE.EQ.19) THEN
  462.             IF (P2.NE.0) THEN
  463.                 NTYPE2=ZYNTYP(P2)
  464.                 IF (NTYPE2.NE.108) THEN
  465.                     TMP=ZYDOWN(P2)
  466.                     IF (TMP.NE.0) THEN
  467.                         IF (ZYNTYP(TMP).EQ.17) THEN
  468.                             CALL ZYXSVA(TMP,0)
  469.                         ELSE
  470.                             STATUS=-2
  471.                             CALL EXPR(TMP,.TRUE.,0,STATUS)
  472.                             IF (STATUS.EQ.-2)
  473.      +                          CALL CHKTYP(NTYPE2,ZYXGVA(TMP))
  474.                         END IF
  475.                     END IF
  476.                     P2=ZYNEXT(P2)
  477.                     IF (ZYNTYP(P2).NE.108)
  478.      +                  CALL ERRMES('PASS1: CORRUPT TREE',-1001)
  479.                 END IF
  480.                 IF (NTYPE.EQ.8 .OR. NTYPE.EQ.16)
  481.      +              CALL PROSUB(P2)
  482.             ELSE IF (NTYPE.EQ.19) THEN
  483.                 PUNAME='$BLOCK'
  484.             ELSE
  485.                 CALL ERRMES('PROPU: IMPOSSIBLE ERROR',-1001)
  486.             END IF
  487.         ELSE IF (NTYPE.EQ.18) THEN
  488.             IF (BLKDTA) CALL ERRMES('Invalid statement in BLOCK DATA',
  489.      +                              -1)
  490.             CALL PROSUB(P2)
  491.         ELSE IF (NTYPE.EQ.39) THEN
  492.             CALL PROSAV(P2,MAIN)
  493.         ELSE IF (NTYPE.EQ.32) THEN
  494.  150        TMP=ZYDOWN(P2)
  495.             IF (ZYDOWN(TMP).NE.0) THEN
  496.                 STATUS=-2
  497.                 CALL EXPR(ZYDOWN(TMP),.TRUE.,0,STATUS)
  498.                 IF (STATUS.EQ.-2)
  499.      +              CALL CHKTYP(ZYNTYP(TMP),ZYXGVA(ZYDOWN(TMP)))
  500.             END IF
  501.             P2=ZYNEXT(P2)
  502.             IF (P2.NE.0) GOTO 150
  503.         ELSE IF (NTYPE.EQ.78) THEN
  504.             CALL PROFMT(P2)
  505.         ELSE IF (NTYPE.NE.62 .AND. NTYPE.NE.6 .AND.
  506.      +           NTYPE.NE.51 .AND. NTYPE.NE.59 .AND.
  507.      +           NTYPE.NE.60 .AND. NTYPE.NE.24) THEN
  508.             CALL ERRMES('Unknown statement type',-1)
  509.         END IF
  510. C Check for ending a DO loop
  511.         IF (LABLED .AND. NTYPE.NE.61 .AND. DOLVL.GT.0) THEN
  512.  200        IF (DOLBL(DOLVL).EQ.LABEL) THEN
  513.                 DOLVL=DOLVL-1
  514.                 IF (DOLVL.GT.0) GOTO 200
  515.             END IF
  516.         END IF
  517.         P2=PTR
  518.         PTR=ZYNEXT(PTR)
  519.         STMTNO=STMTNO+1
  520.         IF (PTR.NE.0) GOTO 100
  521. C Check for the conditional statement part of a logical IF
  522.         PTR=ZYUP(P2)
  523.         IF (PTR.NE.PUROOT) THEN
  524.             PTR=ZYNEXT(PTR)
  525.             GOTO 100
  526.         END IF
  527.         STMTNO=0
  528.         IF (NERROR.EQ.ERRCNT) CALL ZYXCEQ(ERRSYM)
  529.  
  530.         END
  531. C ----------------------------------------------------------------------
  532. C
  533. C       P A S S 2   -   Process a single program unit, pass 2
  534. C
  535.  
  536.         SUBROUTINE PASS2(PUN,MAIN)
  537.         INTEGER PUN
  538.         LOGICAL MAIN
  539.  
  540.         INTEGER COMSTK
  541.         PARAMETER (COMSTK=20)
  542.  
  543.         INTEGER SYMPTR,SYMBOL(8),PUTYPE,COMPTR(COMSTK),COMSP,
  544.      +          I,ARGLST(2),STATUS
  545.  
  546.         INTEGER ZYGNSW,LENGTH,ZIAND,ZYXSCM
  547.         EXTERNAL ZYGNSW,LENGTH,ZYXSCM,ZYXSSU,ZIAND,
  548.      +           ZYXSPA
  549.  
  550.         SYMPTR=0
  551.         COMSP=0
  552.         IF (ZYGNSW(SYMPTR,PUN,SYMBOL).EQ.-100)
  553.      +      CALL ERRMES('No symbols in pu',-1001)
  554.  
  555. C Pass 2A: Push common block pointers onto a stack & scan it later
  556.  
  557.  100    IF (SYMBOL(1).EQ.1) THEN
  558.             IF (SYMBOL(4).EQ.0) THEN
  559.                 CALL ERRSYM('Undefined label - ',SYMPTR,-1)
  560.             ELSE IF (SYMBOL(7)+SYMBOL(5)+
  561.      +               SYMBOL(6).EQ.0) THEN
  562.                 CALL ERRSYM('Unreferenced label - ',SYMPTR,-1002)
  563.             END IF
  564.         ELSE IF (SYMBOL(1).EQ.4) THEN
  565.             PUTYPE=SYMBOL(4)
  566.             IF (SYMBOL(8).EQ.0)
  567.      +          CALL ZYXSPA(SYMPTR,0,ARGLST)
  568.         ELSE IF (SYMBOL(1).EQ.9) THEN
  569.             IF ((SYMBOL(4).EQ.6 .OR.
  570.      +          PUTYPE.EQ.6) .AND. SYMBOL(4).NE.PUTYPE)
  571.      +      THEN
  572.                 CALL ERRSYM('ENTRY type conflict with function - ',
  573.      +                      SYMPTR,-1)
  574.             END IF
  575.         ELSE IF (SYMBOL(1).EQ.2) THEN
  576.             IF (SYMBOL(4).EQ.0) THEN
  577.                 CALL ERRSYM('Common block SAVEd but does n'//'ot appe'//
  578.      +                      'ar in a COMMON statement - ',SYMPTR,-1)
  579.             ELSE
  580.                 COMSP=COMSP+1
  581.                 IF (COMSP.LE.COMSTK) COMPTR(COMSP)=SYMPTR
  582.             END IF
  583.         ELSE IF (SYMBOL(1).EQ.5) THEN
  584.             CALL ZYXSSU(SYMPTR)
  585.         END IF
  586.         IF (ZYGNSW(SYMPTR,PUN,SYMBOL).NE.-100) GOTO 100
  587.  
  588. C Pass2B: Process the common block pointers
  589.  
  590.         DO 200 I=1,MIN(COMSP,COMSTK)
  591.             STATUS=ZYXSCM(COMPTR(I),MAIN)
  592.             IF (STATUS.EQ.-67) THEN
  593.                 CALL ERRSYM('Internal Error processing common block ',
  594.      +                      COMPTR(I),-1001)
  595.             ELSE IF (STATUS.EQ.-68) THEN
  596.                 CALL ERRSYM('Unused common block - ',COMPTR(I),-1002)
  597.             ELSE IF (STATUS.NE.-2) THEN
  598.                 CALL ERRSYM(
  599.      +'Unknown return from ZYXSCM for ',COMPTR(I),-1001)
  600.             END IF
  601.  200    CONTINUE
  602.         IF (COMSP.GT.COMSTK) THEN
  603.             SYMPTR=COMPTR(COMSTK)
  604.             IF (ZYGNSW(SYMPTR,PUN,SYMBOL).EQ.-100)
  605.      +          CALL ERRMES('PASS2: INTERNAL ERROR (COMMON BLOCKS)',
  606.      +                      -1001)
  607.  300        IF (SYMBOL(1).EQ.2) THEN
  608.                 STATUS=ZYXSCM(SYMPTR,MAIN)
  609.                 IF (STATUS.EQ.-67) THEN
  610.                     CALL ERRSYM(
  611.      +                  'Internal Error processing common block ',
  612.      +                  SYMPTR,-1001)
  613.                 ELSE IF (STATUS.EQ.-68) THEN
  614.                     CALL ERRSYM('Unused common block - ',SYMPTR,
  615.      +                          -1002)
  616.                 ELSE IF (STATUS.NE.-2) THEN
  617.                     CALL ERRSYM(
  618.      +'Unknown return from ZYXSCM for ',SYMPTR,-1001)
  619.                 END IF
  620.             END IF
  621.             IF (ZYGNSW(SYMPTR,PUN,SYMBOL).EQ.-2) GOTO 300
  622.         END IF
  623.  
  624.         END
  625. C ----------------------------------------------------------------------
  626. C
  627. C       P A S S 3   -   Process a single program unit, pass 3
  628. C
  629.  
  630.         SUBROUTINE PASS3(PUROOT,MAIN)
  631.         INTEGER PUROOT
  632.         LOGICAL MAIN
  633.  
  634.         COMMON/CONTXT/PUN,STMTNO
  635.         INTEGER PUN,STMTNO
  636.  
  637.         INTEGER PTR,SETPTR,ITMPTR,LASPTR,CURSUN,LASSUN,ITMSYM,LASSYM,
  638.      +          SYMBOL(8),STATUS
  639.  
  640.         INTEGER GETSU
  641.  
  642.         INTEGER ZYDOWN,ZYNEXT,ZYNTYP,ZYXEQV
  643.         EXTERNAL ZYDOWN,ZYNEXT,ZYNTYP,ZYXEQV
  644.  
  645.         STMTNO=1
  646.         PTR=ZYDOWN(PUROOT)
  647.  100    IF (ZYNTYP(PTR).EQ.24) THEN
  648.             SETPTR=ZYDOWN(PTR)
  649.  200        ITMPTR=ZYDOWN(SETPTR)
  650.             ITMSYM=-ZYDOWN(ITMPTR)
  651.             IF (ITMSYM.LT.0) ITMSYM=-ZYDOWN(-ITMSYM)
  652.             IF (ITMSYM.LT.0) ITMSYM=-ZYDOWN(-ITMSYM)
  653.             CURSUN=GETSU(ITMPTR)
  654.             IF (CURSUN.EQ.-1) RETURN
  655.  300        LASPTR=ITMPTR
  656.             LASSUN=CURSUN
  657.             LASSYM=ITMSYM
  658.             ITMPTR=ZYNEXT(ITMPTR)
  659.             IF (ITMPTR.NE.0) THEN
  660.                 ITMSYM=-ZYDOWN(ITMPTR)
  661.                 IF (ITMSYM.LT.0) ITMSYM=-ZYDOWN(-ITMSYM)
  662.                 IF (ITMSYM.LT.0) ITMSYM=-ZYDOWN(-ITMSYM)
  663.                 CURSUN=GETSU(ITMPTR)
  664.                 IF (CURSUN.EQ.-1) RETURN
  665.                 STATUS=ZYXEQV(LASSYM,LASSUN,ITMSYM,CURSUN)
  666.                 IF (STATUS.EQ.-69) THEN
  667.                     CALL ERRMES('Inconsistent EQUIVALENCEs',-1)
  668.                 ELSE IF (STATUS.EQ.-70) THEN
  669.                     CALL ERRMES('Dummy argument in EQUIVALENCE',-1)
  670.                     GOTO 400
  671.                 END IF
  672.                 GOTO 300
  673.             END IF
  674.  400        SETPTR=ZYNEXT(SETPTR)
  675.             IF (SETPTR.GT.0) GOTO 200
  676.         END IF
  677.         PTR=ZYNEXT(PTR)
  678.         STMTNO=STMTNO+1
  679.         IF (PTR.NE.0) GOTO 100
  680.         STMTNO=0
  681.  
  682.         END
  683. C ----------------------------------------------------------------------
  684. C
  685. C       P A S S 4   -   Process the entire file, pass 4
  686. C                       : Global linkage information
  687. C
  688.  
  689.         SUBROUTINE PASS4
  690.  
  691.         COMMON/PUNAMC/PUNAME
  692.         CHARACTER*6 PUNAME
  693.  
  694.         INTEGER SYMPTR,SYMBOL(8),STATUS,PUSYM,TEXT(134),
  695.      +          RESULT(8),PUN
  696.  
  697.         SAVE /PUNAMC/
  698.  
  699.         INTEGER ZYGNSY,ZYXAPU,ZYXAEN,ZYXACO,ZYXAPR,
  700.      +          ZIAND,ZYGPUS
  701.         EXTERNAL ZYGNSY,ZYXAPU,ZYXAEN,ZYXACO,ZYXAPR,
  702.      +           ZIAND,ZYXAAP,ZYXAUS,ZYGPUS
  703.  
  704.         SYMPTR=0
  705.         IF (ZYGNSY(SYMPTR,SYMBOL).EQ.-100)
  706.      +      CALL ERRMES('PASS4: No symbols found',-1001)
  707.  
  708.  100    IF (SYMBOL(1).EQ.4) THEN
  709.             CALL ZYGTST(SYMBOL(2),TEXT)
  710.             CALL ZITOF(TEXT,1,6,PUNAME,.FALSE.)
  711.             IF (ZYXAPU(SYMPTR).NE.-2)
  712.      +          CALL ERRSYM('Program unit occurs twice',SYMPTR,-1)
  713.         ELSE IF (SYMBOL(1).EQ.9) THEN
  714.             IF (ZYXAEN(SYMPTR,ZYGPUS(SYMBOL(3))).NE.-2)
  715.      +          CALL ERRSYM('ENTRY duplicates a global name - ',SYMPTR,
  716.      +                      -1)
  717.         END IF
  718.         IF (ZYGNSY(SYMPTR,SYMBOL).NE.-100) GOTO 100
  719.  
  720.         SYMPTR=0
  721.         PUSYM=0
  722.         PUN=0
  723.         IF (ZYGNSY(SYMPTR,SYMBOL).EQ.-100)
  724.      +      CALL ERRMES('PASS4 PART TWO: No symbols found',-1001)
  725.  
  726.  200    IF (SYMBOL(3).NE.PUN) THEN
  727.             PUN=SYMBOL(3)
  728.             PUSYM=ZYGPUS(PUN)
  729.             CALL ZYGTSY(PUSYM,RESULT)
  730.             CALL ZYGTST(RESULT(2),TEXT)
  731.             CALL ZITOF(TEXT,1,6,PUNAME,.FALSE.)
  732.         END IF
  733.         IF (SYMBOL(1).EQ.2) THEN
  734.             STATUS=ZYXACO(SYMPTR)
  735.             IF (STATUS.EQ.-63) THEN
  736.                 CALL ERRSYM('Inconsistent COMMON SAVE-ing for ',SYMPTR,
  737.      +                      -1)
  738.             ELSE IF (STATUS.EQ.-64) THEN
  739.                 CALL ERRSYM('Inconsistent size of COMMON ',SYMPTR,-1)
  740.             ELSE IF (STATUS.EQ.-65) THEN
  741.                 CALL ERRSYM('COMMON name conflicts with program unit '//
  742.      +                      'name - ',SYMPTR,-1)
  743.             ELSE IF (STATUS.EQ.-66) THEN
  744.                 CALL ERRSYM('COMMON block initialised too often - ',
  745.      +                      SYMPTR,-1)
  746.             END IF
  747.         END IF
  748.         IF (ZYGNSY(SYMPTR,SYMBOL).NE.-100) GOTO 200
  749.  
  750.         SYMPTR=0
  751.         PUSYM=0
  752.         PUN=0
  753.         IF (ZYGNSY(SYMPTR,SYMBOL).EQ.-100)
  754.      +      CALL ERRMES('PASS4 PART THREE: No symbols found',-1001)
  755.  300    IF (SYMBOL(3).NE.PUN) THEN
  756.             PUN=SYMBOL(3)
  757.             PUSYM=ZYGPUS(PUN)
  758.             CALL ZYGTSY(PUSYM,RESULT)
  759.             CALL ZYGTST(RESULT(2),TEXT)
  760.             CALL ZITOF(TEXT,1,6,PUNAME,.FALSE.)
  761.         END IF
  762.         IF (SYMBOL(1).EQ.7) THEN
  763.             IF (ZIAND(SYMBOL(6),4096+2)
  764.      +          .EQ.0 .OR. ZIAND(SYMBOL(6),2048).NE.0)
  765.      +      THEN
  766.                 STATUS=ZYXAPR(SYMPTR)
  767.                 IF (STATUS.EQ.-51) THEN
  768.                     CALL ERRSYM('Inconsistent subprogram type: ',SYMPTR,
  769.      +                          -1)
  770.                 ELSE IF (STATUS.EQ.-52) THEN
  771.                     CALL ERRSYM('Inconsistent nu'//'mber of args to ',
  772.      +                          SYMPTR,-1)
  773.                 ELSE IF (STATUS.EQ.-53) THEN
  774.                     CALL ERRSYM('Inconsistent arg structure to ',
  775.      +                          SYMPTR,-1)
  776.                 ELSE IF (STATUS.EQ.-54) THEN
  777.                     CALL ERRSYM('Inconsistent arg type to ',SYMPTR,-1)
  778.                 ELSE IF (STATUS.EQ.-55) THEN
  779.                     CALL ERRSYM('Wrong subprogram datatype: ',SYMPTR,
  780.      +                          -1)
  781.                 ELSE IF (STATUS.EQ.-56) THEN
  782.                     CALL ERRSYM('Wrong nu'//'mber of arguments to ',
  783.      +                          SYMPTR,-1)
  784.                 ELSE IF (STATUS.EQ.-57) THEN
  785.                     CALL ERRSYM('Wrong type of argument to ',SYMPTR,
  786.      +                          -1)
  787.                ELSE IF (STATUS.EQ.-58) THEN
  788.                     CALL ERRSYM('Unexpected return from ZYXAPR',
  789.      +                          SYMPTR,-1001)
  790.                ELSE IF (STATUS.EQ.-59) THEN
  791.                     CALL ERRSYM('Wrong structure of argument to ',
  792.      +                          SYMPTR,-1)
  793.                 ELSE IF (STATUS.EQ.-60) THEN
  794.                     CALL ERRSYM('Character argument too short to ',
  795.      +                          SYMPTR,-1)
  796.                 ELSE IF (STATUS.EQ.-61) THEN
  797.                     CALL ERRSYM('External name clashes with common '//
  798.      +                          'block name - ',SYMPTR,-1)
  799.                 ELSE IF (STATUS.EQ.-62) THEN
  800.                     CALL ERRSYM('Unused external: ',SYMPTR,-1002)
  801.                 ELSE IF (STATUS.NE.-2) THEN
  802.                     CALL ERRMES('UNKNOWN RESULT FROM ZYXAPR',-1001)
  803.                 END IF
  804.             END IF
  805.         END IF
  806.         IF (ZYGNSY(SYMPTR,SYMBOL).NE.-100) GOTO 300
  807.  
  808.         CALL ZYXAAP
  809.         CALL ZYXAUS
  810.  
  811.         END
  812. C ----------------------------------------------------------------------
  813. C
  814. C       P R O L I F   -   Process a logical IF statement
  815. C
  816.  
  817.         SUBROUTINE PROLIF(NODE)
  818.         INTEGER NODE
  819.  
  820.         INTEGER STATUS,NTYPE,BITS,DTYPE
  821.  
  822.         INTEGER ZYXGDT,ZYNEXT,ZYNTYP,ZYXGTB,ZIAND
  823.         EXTERNAL ZYXGDT,ZYNEXT,ZYNTYP,ZYXGTB,ZIAND
  824.  
  825.         STATUS=-2
  826.         CALL EXPR(NODE,.FALSE.,0,STATUS)
  827.         IF (STATUS.NE.-2) RETURN
  828.         DTYPE=ZYXGDT(NODE)
  829.         IF (DTYPE.NE.3 .AND. DTYPE.NE.12 .AND.
  830.      +      DTYPE.NE.13) THEN
  831.             CALL ERRMES('Expression in logical IF must be logical',-1)
  832.             RETURN
  833.         END IF
  834.         BITS=ZYXGTB(NODE)
  835.         IF (ZIAND(BITS,8388608+4194304).NE.0) THEN
  836.             CALL ERRMES('Logical IF expression is array/proc',-1)
  837.         ELSE IF (ZIAND(BITS,2097152).NE.0) THEN
  838.             CALL ERRMES('Logical IF expression is constant',-2)
  839.         END IF
  840.         NTYPE=ZYNTYP(ZYNEXT(NODE))
  841.         IF (NTYPE.EQ.61 .OR. NTYPE.EQ.57 .OR.
  842.      +      NTYPE.EQ.58 .OR. NTYPE.EQ.59 .OR.
  843.      +      NTYPE.EQ.60 .OR. NTYPE.EQ.6 .OR.
  844.      +      NTYPE.EQ.56)
  845.      +      CALL ERRMES('Illegal conditional statement in logical IF',
  846.      +                  -1)
  847.  
  848.         END
  849. C ----------------------------------------------------------------------
  850. C
  851. C       P R O B I F   -   Process block IF/ELSEIF statement
  852. C
  853.  
  854.         SUBROUTINE PROBIF(NODE)
  855.         INTEGER NODE
  856.  
  857.         INTEGER STATUS,BITS,DTYPE
  858.  
  859.         INTEGER ZYXGDT,ZYXGTB,ZIAND
  860.         EXTERNAL ZYXGDT,ZYXGTB,ZIAND
  861.  
  862.         STATUS=-2
  863.         CALL EXPR(NODE,.FALSE.,0,STATUS)
  864.         IF (STATUS.EQ.-1) RETURN
  865.         DTYPE=ZYXGDT(NODE)
  866.         IF (DTYPE.NE.3.AND. DTYPE.NE.12 .AND.
  867.      +      DTYPE.NE.13) THEN
  868.             CALL ERRMES('Conditional expression must be type logical',
  869.      +                  -1)
  870.         ELSE
  871.             BITS=ZYXGTB(NODE)
  872.             IF (ZIAND(BITS,4194304+8388608).NE.0) THEN
  873.                 CALL ERRMES('Conditional expr is array/proc',-1)
  874.             ELSE IF (ZIAND(BITS,2097152).NE.0) THEN
  875.                 CALL ERRMES('Conditional expression is constant',-2)
  876.             END IF
  877.         END IF
  878.  
  879.         END
  880. C ----------------------------------------------------------------------
  881. C
  882. C       P R O P R I   -   Process a PRINT statement
  883. C
  884.  
  885.         SUBROUTINE PROPRI(NODE)
  886.         INTEGER NODE
  887.  
  888.         INTEGER PTR,STATUS
  889.  
  890.         INTEGER ZYNEXT
  891.         EXTERNAL ZYNEXT
  892.  
  893.         STATUS=-2
  894.         CALL FMTID(NODE,STATUS)
  895.         IF (STATUS.EQ.-1) RETURN
  896.         PTR=ZYNEXT(NODE)
  897.         IF (PTR.NE.0) CALL IOLIST(PTR)
  898.  
  899.         END
  900. C ----------------------------------------------------------------------
  901. C
  902. C       P R O W R I   -   Process a WRITE statement
  903. C
  904.  
  905.         SUBROUTINE PROWRI(NODE)
  906.         INTEGER NODE
  907.  
  908.         INTEGER PTR,STATUS
  909.  
  910.         INTEGER ZYNTYP,ZYNEXT
  911.         EXTERNAL ZYNTYP,ZYNEXT
  912.  
  913.         STATUS=-2
  914.         CALL CILIST(NODE,STATUS)
  915.         IF (STATUS.EQ.-1) RETURN
  916.         PTR=ZYNEXT(NODE)
  917.         IF (PTR.NE.0) CALL IOLIST(PTR)
  918.  
  919.         END
  920. C ----------------------------------------------------------------------
  921. C
  922. C       P R O R E A   -   Process a READ statement
  923. C
  924.  
  925.         SUBROUTINE PROREA(NODE)
  926.         INTEGER NODE
  927.  
  928.         INTEGER PTR,NTYPE,STATUS,TMP
  929.  
  930.         INTEGER ZYNEXT,ZYNTYP,ZYCRND,ZYXGDT
  931.         EXTERNAL ZYNEXT,ZYNTYP,ZYCRND,ZYCHNT,ZYADSN,ZYREPL,ZYXGDT
  932.  
  933.         STATUS=-2
  934.         NTYPE=ZYNTYP(NODE)
  935.         IF (NTYPE.EQ.123) THEN
  936.             CALL FMTID(NODE,STATUS)
  937.         ELSE IF (NTYPE.EQ.68) THEN
  938.             CALL CILIST(NODE,STATUS)
  939.         ELSE IF (NTYPE.EQ.124) THEN
  940. C Could be a format-expression or ci-list - we have to check
  941. C Assume it is going to be a format expression (type char)
  942.             CALL ZYCHNT(NODE,101)
  943.             CALL EXPR(NODE,.FALSE.,0,STATUS)
  944.             IF (STATUS.EQ.-1) RETURN
  945.             IF (ZYXGDT(NODE).EQ.1) THEN
  946. C type integer - it is a cilist - say so (remove the b..... parentheses)
  947.                 CALL ZYCHNT(NODE,122)
  948.                 PTR=ZYCRND(68,0)
  949.                 CALL ZYREPL(NODE,PTR)
  950.                 CALL ZYADSN(PTR,NODE)
  951.             ELSE IF (ZYXGDT(NODE).NE.6) THEN
  952.                 CALL ERRMES('Invalid READ statement',-1)
  953.                 STATUS=-1
  954.             END IF
  955.         ELSE IF (NTYPE.EQ.101) THEN
  956. C Parenthesised format expression - no N_FMTID node.
  957.             CALL EXPR(NODE,.FALSE.,0,STATUS)
  958.         ELSE
  959.             CALL ERRMES('PROREA: DON''T UNDERSTAND TREE',-1001)
  960.         END IF
  961.         IF (STATUS.EQ.-1) RETURN
  962.         PTR=ZYNEXT(NODE)
  963.         IF (PTR.NE.0) CALL IOLIST(PTR)
  964.  
  965.         END
  966. C ----------------------------------------------------------------------
  967. C
  968. C       P R O A U X   -   Process an auxiliary i/o statement
  969. C
  970.  
  971.         SUBROUTINE PROAUX(NODE)
  972.         INTEGER NODE
  973.  
  974.         INTEGER STATUS,PTR
  975.  
  976.         INTEGER ZYNTYP,ZYXGDT,ZYXGTB,ZIAND,ZYDOWN,ZYNEXT
  977.         EXTERNAL ZYNTYP,ZYXGDT,ZYXGTB,ZIAND,ZYDOWN,ZYNEXT
  978.  
  979.         LOGICAL BADP
  980.         INTEGER ARGN
  981.  
  982.         BADP(ARGN)=ZIAND(ZYXGTB(ARGN),4194304+8388608).NE.0
  983.  
  984.         STATUS=-2
  985.         IF (ZYNTYP(NODE).EQ.122) THEN
  986.             PTR=ZYDOWN(NODE)
  987.             IF (ZYNTYP(PTR).NE.17) THEN
  988.                 CALL EXPR(PTR,.FALSE.,0,STATUS)
  989.                 IF (STATUS.EQ.-1) RETURN
  990.                 IF (ZYXGDT(PTR).NE.1) THEN
  991.                     CALL ERRMES('Unit-identifier must be integer',-1)
  992.                     RETURN
  993.                 ELSE IF (BADP(PTR)) THEN
  994.                     CALL ERRMES('Unit-identifier is array/proc',-1)
  995.                     RETURN
  996.                 END IF
  997.             END IF
  998.             PTR=ZYNEXT(NODE)
  999.         ELSE
  1000.             PTR=NODE
  1001.         END IF
  1002.         IF (PTR.NE.0) CALL CILIST(PTR,STATUS)
  1003.  
  1004.  
  1005.         END
  1006. C ----------------------------------------------------------------------
  1007. C
  1008. C
  1009. C       P R O P A R   -   Process a PARAMETER statement
  1010. C
  1011.  
  1012.         SUBROUTINE PROPAR(NODE)
  1013.         INTEGER NODE
  1014.  
  1015.         INTEGER PTR,STATUS,SYMPTR,SYMBOL(8),NTYPE
  1016.  
  1017.         INTEGER ZYDOWN,ZYNEXT,ZYXGVA,ZYXGDT
  1018.         EXTERNAL ZYDOWN,ZYNEXT,ZYSATT,ZYSABT,ZYXGVA,ZYGTSY,
  1019.      +           ZYXGDT
  1020.  
  1021.         PTR=NODE
  1022.  100    CALL EXPR(ZYNEXT(ZYDOWN(PTR)),.TRUE.,0,STATUS)
  1023.         IF (STATUS.EQ.-2) THEN
  1024.             SYMPTR=-ZYDOWN(ZYDOWN(PTR))
  1025.             CALL ZYSABT(SYMPTR,6,262144)
  1026.             CALL ZYGTSY(SYMPTR,SYMBOL)
  1027.             NTYPE=ZYXGDT(ZYNEXT(ZYDOWN(PTR)))
  1028.             IF (SYMBOL(4).EQ.1) THEN
  1029.                 IF (NTYPE.EQ.1) THEN
  1030.                     CALL ZYSATT(SYMPTR,8,
  1031.      +                   ZYXGVA(ZYNEXT(ZYDOWN(PTR))))
  1032.                 ELSE IF (NTYPE.EQ.6 .OR. NTYPE.EQ.3
  1033.      +                   .OR. NTYPE.EQ.12
  1034.      +                   .OR. NTYPE.EQ.13) THEN
  1035.                     CALL ERRMES ('Invalid integer PARAMETER'//
  1036.      +                   ' expression',-1)
  1037.                 ELSE
  1038.                     CALL ERRMES ('Integer PARAMETER expression n'//
  1039.      +                   'ot integer',-1002)
  1040.                 ENDIF
  1041.             ELSE IF (SYMBOL(4).EQ.6) THEN
  1042.                 IF (NTYPE.EQ.6) THEN
  1043.                 CALL ZYSATT(SYMPTR,8,
  1044.      +               ZYXGVA(ZYNEXT(ZYDOWN(PTR))))
  1045.                 ELSE
  1046.                 CALL ERRMES ('Invalid character PARAMETER'//
  1047.      +               ' expression',-1)
  1048.                 ENDIF
  1049.             ELSE IF (SYMBOL(4).EQ.3 .OR.
  1050.      +               SYMBOL(4).EQ.12 .OR.
  1051.      +               SYMBOL(4).EQ.13) THEN
  1052.                 IF (NTYPE.NE.3 .AND. NTYPE.NE.12
  1053.      +               .AND. NTYPE.NE.13)
  1054.      +               CALL ERRMES ('Invalid logical PARAMETER'//
  1055.      +               ' expression',-1)
  1056.             ELSE IF (NTYPE.EQ.6) THEN
  1057.                 CALL ERRMES ('Invalid character expression in'//
  1058.      +                        ' PARAMETER',-1)
  1059.             ELSE IF (NTYPE.EQ.3 .OR. NTYPE.EQ.12
  1060.      +               .OR. NTYPE.EQ.13) THEN
  1061.                 CALL ERRMES ('Invalid logical expression in'//
  1062.      +                        ' PARAMETER',-1)
  1063.             ENDIF
  1064.         END IF
  1065.         PTR=ZYNEXT(PTR)
  1066.         IF (PTR.NE.0) GOTO 100
  1067.  
  1068.         END
  1069. C ----------------------------------------------------------------------
  1070. C
  1071. C       P R O T Y P   -   Process a type or DIMENSION statement
  1072. C
  1073.  
  1074.         SUBROUTINE PROTYP(NODE)
  1075.         INTEGER NODE
  1076.  
  1077.         INTEGER PTR,STATUS,P2,NTYPE
  1078.  
  1079.         INTEGER ZYDOWN,ZYNTYP,ZYNEXT,ZYXGDT,ZYXGVA
  1080.         EXTERNAL ZYDOWN,ZYNTYP,ZYNEXT,ZYXGDT,ZYXSVA,ZYXGVA
  1081.  
  1082.         PTR=NODE
  1083.         STATUS=-2
  1084.  100    NTYPE=ZYNTYP(PTR)
  1085.         IF (NTYPE.EQ.21) THEN
  1086.             CALL ARRAYD(PTR)
  1087.         ELSE IF (NTYPE.EQ.10 .OR. NTYPE.EQ.13 .OR.
  1088.      +           NTYPE.EQ.9) THEN
  1089.             P2=ZYDOWN(PTR)
  1090.             IF (P2.NE.0) THEN
  1091.                 CALL EXPR(P2,.TRUE.,0,STATUS)
  1092.                 IF (STATUS.EQ.-2) THEN
  1093.                     IF (ZYXGDT(P2).NE.1) THEN
  1094.                         CALL ERRMES('Invalid expression type',-1)
  1095.                     ELSE
  1096.                         CALL CHKTYP(NTYPE,ZYXGVA(P2))
  1097.                     END IF
  1098.                 END IF
  1099.             END IF
  1100.         ELSE IF (NTYPE.EQ.14) THEN
  1101.             P2=ZYDOWN(PTR)
  1102.             IF (P2.EQ.0) THEN
  1103. C Nothing to do
  1104.                 CONTINUE
  1105.             ELSE IF (ZYNTYP(P2).EQ.17) THEN
  1106.                 CALL ZYXSVA(P2,0)
  1107.             ELSE
  1108.                 CALL EXPR(P2,.TRUE.,0,STATUS)
  1109.                 IF (STATUS.EQ.-2) THEN
  1110.                     IF (ZYXGDT(P2).NE.1) THEN
  1111.                         CALL ERRMES('Invalid expression type',-1)
  1112.                         STATUS=-1
  1113.                     ELSE IF (ZYXGVA(P2).LE.0) THEN
  1114.                         CALL ERRMES('Character length must be positive',
  1115.      +                              -1)
  1116.                         STATUS=-1
  1117.                     END IF
  1118.                 END IF
  1119.             END IF
  1120.         ELSE IF (NTYPE.EQ.31) THEN
  1121.             P2=ZYDOWN(PTR)
  1122.             IF (ZYNTYP(P2).EQ.21) CALL ARRAYD(P2)
  1123.             P2=ZYNEXT(P2)
  1124.             IF (ZYNTYP(P2).EQ.17) THEN
  1125.                 CALL ZYXSVA(P2,0)
  1126.             ELSE
  1127.                 CALL EXPR(P2,.TRUE.,0,STATUS)
  1128.                 IF (STATUS.EQ.-2 .AND. ZYXGDT(P2).NE.1) THEN
  1129.                     CALL ERRMES('Invalid expression type',-1)
  1130.                     STATUS=-1
  1131.                 END IF
  1132.             END IF
  1133.         END IF
  1134.         IF (STATUS.EQ.-1) RETURN
  1135.         PTR=ZYNEXT(PTR)
  1136.         IF (PTR.NE.0) GOTO 100
  1137.  
  1138.         END
  1139. C ----------------------------------------------------------------------
  1140. C
  1141. C       P R O C O M   -   Process a COMMON statement
  1142. C
  1143.  
  1144.         SUBROUTINE PROCOM(NODE,BLKDTA)
  1145.         INTEGER NODE
  1146.         LOGICAL BLKDTA
  1147.  
  1148.         COMMON/CONTXT/PUN,STMTNO
  1149.         INTEGER PUN,STMTNO
  1150.  
  1151.         INTEGER PTR,COMPTR,SYMBOL(8),TEXT(8),P2,ELTPTR
  1152.  
  1153.         SAVE TEXT
  1154.  
  1155.         INTEGER ZYDOWN,ZYNEXT,ZYNTYP,ZYFSYM,ZIAND,ZYXATC
  1156.         EXTERNAL ZYDOWN,ZYNEXT,ZYNTYP,ZYFSYM,ZIAND,ZYXATC
  1157.  
  1158.         DATA TEXT/36,67,79,77,77,79,78,129/
  1159.  
  1160.         PTR=NODE
  1161.  100    P2=ZYDOWN(PTR)
  1162.         IF (ZYNTYP(PTR).EQ.27) THEN
  1163. C Actually, blank common is not illegal in itself, it is just illegal
  1164. C to initially define (via DATA) anything in it...
  1165.             IF (BLKDTA)
  1166.      +          CALL ERRMES('Blank COMMON illegal in BLOCK DATA',-1)
  1167.             COMPTR=ZYFSYM(TEXT,PUN,SYMBOL)
  1168.             IF (COMPTR.EQ.-1)
  1169.      +          CALL ERRMES('Couldn''t find Blank Common',-1001)
  1170.         ELSE
  1171.             COMPTR=-ZYDOWN(P2)
  1172.             P2=ZYNEXT(P2)
  1173.         END IF
  1174.         P2=ZYDOWN(P2)
  1175.  200    IF (ZYNTYP(P2).EQ.21) THEN
  1176.             CALL ARRAYD(P2)
  1177.             ELTPTR=ZYDOWN(P2)
  1178.         ELSE
  1179.             ELTPTR=P2
  1180.         END IF
  1181.         ELTPTR=-ZYDOWN(ELTPTR)
  1182.         CALL ZYGTSY(ELTPTR,SYMBOL)
  1183.         IF (ZIAND(SYMBOL(6),4).NE.0 .OR.
  1184.      +      SYMBOL(1).EQ.4) THEN
  1185.             CALL ERRMES('Invalid variable in COMMON',-1)
  1186.         ELSE IF (ZYXATC(COMPTR,ELTPTR).EQ.-1) THEN
  1187.             CALL ERRMES('Variable occurs more than once in COMMON',-1)
  1188.         END IF
  1189.         P2=ZYNEXT(P2)
  1190.         IF (P2.NE.0) GOTO 200
  1191.         PTR=ZYNEXT(PTR)
  1192.         IF (PTR.NE.0) GOTO 100
  1193.  
  1194.         END
  1195. C ----------------------------------------------------------------------
  1196. C
  1197. C       P R O D A T   -   Process a DATA statement
  1198. C
  1199.  
  1200.         SUBROUTINE PRODAT(NODE,BLKDTA)
  1201.         INTEGER NODE
  1202.         LOGICAL BLKDTA
  1203.  
  1204.         INTEGER PTR,PTRI,STATUS,NTYPE,SYMBOL(8),PLACE,OFFSET
  1205.  
  1206.         INTEGER ZYDOWN,ZYNEXT,ZYXGVA,ZYXGTB,ZYXGDT,ZYNTYP,
  1207.      +          ZIAND,ZYXGEL,ZYUP
  1208.         EXTERNAL ZYDOWN,ZYNEXT,ZYXGVA,ZYXGTB,ZYXGDT,ZYNTYP,
  1209.      +          ZIAND,ZYXGEL,ZYUP,ZYXGVL
  1210.  
  1211.         PTR=NODE
  1212.         STATUS=-2
  1213.  
  1214.  100    PTRI=ZYDOWN(PTR)
  1215.         CALL DVINIT(ZYDOWN(ZYNEXT(PTRI)),ZYUP(NODE))
  1216.         PTRI=ZYDOWN(PTRI)
  1217.         CALL INIDID
  1218.  
  1219.  200    NTYPE=ZYNTYP(PTRI)
  1220.         IF (NTYPE.EQ.108) THEN
  1221.             CALL ZYGTSY(-ZYDOWN(PTRI),SYMBOL)
  1222.             IF (ZIAND(SYMBOL(6),4).NE.0) THEN
  1223.                 CALL ERRMES('Dummy argument in DATA',-1)
  1224.                 RETURN
  1225.             ELSE
  1226.                 CALL ZYXGVL(-ZYDOWN(PTRI),PLACE,OFFSET)
  1227.                 IF (BLKDTA.NEQV.PLACE.GT.0) THEN
  1228.                     IF (BLKDTA) THEN
  1229.                         CALL ERRMES(
  1230.      +'Only COMMON may be initialised in BLOCK DATA',-1)
  1231.                     ELSE
  1232.                         CALL ERRMES(
  1233.      +'COMMON may only be initialised in BLOCK DATA',-1)
  1234.                     END IF
  1235.                 END IF
  1236.             END IF
  1237.             IF (SYMBOL(7).EQ.0) THEN
  1238.                 CALL DV(SYMBOL(4),1)
  1239.             ELSE
  1240.                 CALL DV(SYMBOL(4),ZYXGEL(-ZYDOWN(PTRI)))
  1241.             END IF
  1242.             PTRI=ZYNEXT(PTRI)
  1243.         ELSE IF (NTYPE.EQ.104 .OR. NTYPE.EQ.103) THEN
  1244.             CALL EXPR(PTRI,.TRUE.,1,STATUS)
  1245.             IF (STATUS.EQ.-1) RETURN
  1246.             CALL DV(ZYXGDT(PTRI),1)
  1247.             PTRI=ZYNEXT(PTRI)
  1248.         ELSE IF (NTYPE.EQ.48) THEN
  1249.             CALL ENDDID(PTRI,STATUS)
  1250.             IF (STATUS.EQ.-1) RETURN
  1251.         ELSE
  1252. C NTYPE=N_DATA_IMPDO
  1253.             CALL DID(PTRI,STATUS)
  1254.             IF (STATUS.EQ.-1) RETURN
  1255.         END IF
  1256.         IF (PTRI.NE.0) GOTO 200
  1257. C Check if there are more data values.
  1258.         CALL DVEND
  1259.  
  1260.         PTR=ZYNEXT(PTR)
  1261.         IF (PTR.NE.0) GOTO 100
  1262.  
  1263.         END
  1264. C ----------------------------------------------------------------------
  1265. C
  1266. C       P R O A S G   -   Process an assignment statement
  1267. C
  1268.  
  1269.         SUBROUTINE PROASG(NODE)
  1270.         INTEGER NODE
  1271.  
  1272.         INTEGER SYMBOL(8),PTR,P2,STATUS,NTYPE
  1273.  
  1274.         LOGICAL COMPAT
  1275.         INTEGER ZYDOWN,ZYNEXT,ZYNTYP,ZYXGTB,ZIAND,ZYXGDT
  1276.         EXTERNAL ZYDOWN,ZYNEXT,ZYNTYP,ZYXGTB,ZYGTSY,ZIAND,ZYXGDT
  1277.  
  1278.         PTR=NODE
  1279.         STATUS=-2
  1280.         CALL EXPR(PTR,.FALSE.,0,STATUS)
  1281.         IF (STATUS.NE.-2) RETURN
  1282.         P2=PTR
  1283.         NTYPE=ZYNTYP(PTR)
  1284.         IF (NTYPE.EQ.103) THEN
  1285.             P2=ZYDOWN(PTR)
  1286.             NTYPE=ZYNTYP(P2)
  1287.         END IF
  1288.         IF (NTYPE.EQ.104) P2=ZYDOWN(P2)
  1289.         CALL ZYGTSY(-ZYDOWN(P2),SYMBOL)
  1290.         IF (SYMBOL(1).EQ.4 .OR.
  1291.      +      SYMBOL(1).EQ.9) THEN
  1292.             IF (SYMBOL(4).LT.0) THEN
  1293.                 CALL ERRMES('Illegal assignment to subprogram name',
  1294.      +                      -1)
  1295.                 RETURN
  1296.             END IF
  1297.         ELSE IF (SYMBOL(1).NE.5) THEN
  1298.             CALL ERRMES('PROASG: Invalid parse tree detected',-1001)
  1299.         END IF
  1300.         IF (ZIAND(ZYXGTB(PTR),4194304).NE.0) THEN
  1301.             CALL ERRMES('Missing subscript on lhs of assigment',-1)
  1302.             RETURN
  1303.         END IF
  1304.         P2=ZYNEXT(PTR)
  1305.         CALL EXPR(P2,.FALSE.,0,STATUS)
  1306.         IF (STATUS.NE.-2) RETURN
  1307.         IF (ZIAND(ZYXGTB(P2),4194304).NE.0) THEN
  1308.             CALL ERRMES('Missing subscript on rhs of assignment',-1)
  1309.         ELSE
  1310.             IF (.NOT.COMPAT(ZYXGDT(PTR),ZYXGDT(P2)))
  1311.      +          CALL ERRMES('Incompatible types in assignment',-1)
  1312.         END IF
  1313.  
  1314.         END
  1315. C ----------------------------------------------------------------------
  1316. C
  1317. C       P R O D O   -   Process a DO statement
  1318. C
  1319.  
  1320.         SUBROUTINE PRODO(NODE)
  1321.         INTEGER NODE
  1322.  
  1323.         COMMON/DOSTK/DOLVL,DOLBL,DOIDX
  1324.         INTEGER DOLVL,DOLBL(25),DOIDX(25)
  1325.  
  1326.         SAVE /DOSTK/
  1327.  
  1328.         INTEGER PTR,SYMBOL(8),STATUS,TEXT(9),DTYPE
  1329.  
  1330.         INTEGER CTOI,ZYNEXT,ZYDOWN,ZYXGDT
  1331.         EXTERNAL CTOI,ZYNEXT,ZYDOWN,ZYXGDT,ZYGTSY
  1332.  
  1333.         IF (DOLVL.EQ.25)
  1334.      +      CALL ERRMES('DO loops nested too deeply',-1001)
  1335.         CALL ZYGTSY(-ZYDOWN(NODE),SYMBOL)
  1336.         CALL ZYGTST(SYMBOL(2),TEXT)
  1337.         PTR=1
  1338.         DOLBL(DOLVL+1)=CTOI(TEXT,PTR)
  1339.         PTR=ZYDOWN(ZYNEXT(NODE))
  1340.         DOIDX(DOLVL+1)=-ZYDOWN(PTR)
  1341.         CALL ZYGTSY(DOIDX(DOLVL+1),SYMBOL)
  1342.         IF (SYMBOL(4).NE.1 .AND.
  1343.      +      SYMBOL(4).NE.14 .AND.
  1344.      +      SYMBOL(4).NE.2 .AND.
  1345.      +      SYMBOL(4).NE.5 .AND.
  1346.      +      SYMBOL(4).NE.15) THEN
  1347.             CALL ERRMES('Invalid datatype of DO control variable',-1)
  1348.             RETURN
  1349.         ELSE IF (SYMBOL(1).EQ.5 .AND.
  1350.      +      SYMBOL(7).NE.0) THEN
  1351.             CALL ERRMES('DO control variable must be scalar',-1)
  1352.             RETURN
  1353.         END IF
  1354.         PTR=ZYNEXT(PTR)
  1355.  
  1356.  100    CALL EXPR(PTR,.FALSE.,0,STATUS)
  1357.         IF (STATUS.EQ.-1) RETURN
  1358.         DTYPE=ZYXGDT(PTR)
  1359.         IF (DTYPE.NE.1 .AND. DTYPE.NE.14 .AND.
  1360.      +      DTYPE.NE.2 .AND. DTYPE.NE.5 .AND.
  1361.      +      DTYPE.NE.15) THEN
  1362.             CALL ERRMES('Invalid datatype of DO limit expression',-1)
  1363.             RETURN
  1364.         END IF
  1365.         PTR=ZYNEXT(PTR)
  1366.         IF (PTR.NE.0) GOTO 100
  1367.         DOLVL=DOLVL+1
  1368.  
  1369.         END
  1370. C ----------------------------------------------------------------------
  1371. C
  1372. C       P R O G O A   -   Process assigned GOTO
  1373. C
  1374.  
  1375.         SUBROUTINE PROGOA(NODE)
  1376.         INTEGER NODE
  1377.  
  1378.         INTEGER SYMBOL(8)
  1379.  
  1380.         INTEGER ZYDOWN,ZIAND
  1381.         EXTERNAL ZYDOWN,ZIAND,ZYGTSY
  1382.  
  1383.         CALL ZYGTSY(-ZYDOWN(NODE),SYMBOL)
  1384.         IF (SYMBOL(4).NE.1 .OR.
  1385.      +      SYMBOL(7).NE.0) THEN
  1386.             CALL ERRMES('Assigned GOTO variable must be integer scalar',
  1387.      +                  -1)
  1388.         ELSE IF (ZIAND(SYMBOL(6),16).EQ.0) THEN
  1389.             CALL ERRMES('Assigned GOTO variable never assigned',-1)
  1390.         END IF
  1391.  
  1392.         END
  1393. C ----------------------------------------------------------------------
  1394. C
  1395. C       P R O G O C   -   Process computed GOTO
  1396. C
  1397.  
  1398.         SUBROUTINE PROGOC(NODE)
  1399.         INTEGER NODE
  1400.  
  1401.         INTEGER PTR,STATUS
  1402.  
  1403.         INTEGER ZYNEXT,ZYXGDT
  1404.         EXTERNAL ZYNEXT,ZYXGDT
  1405.  
  1406.         STATUS=-2
  1407.         PTR=ZYNEXT(NODE)
  1408.         CALL EXPR(PTR,.FALSE.,0,STATUS)
  1409.         IF (STATUS.EQ.-1) RETURN
  1410.         IF (ZYXGDT(PTR).NE.1)
  1411.      +      CALL ERRMES('Computed GOTO expr must be of type integer',
  1412.      +                  -1)
  1413.  
  1414.         END
  1415. C ----------------------------------------------------------------------
  1416. C
  1417. C       P R O S F   -   Process statement function definition
  1418. C
  1419.  
  1420.         SUBROUTINE PROSF(NODE)
  1421.         INTEGER NODE
  1422.  
  1423.  
  1424.         INTEGER PTR,SYMBOL(8),SYMPTR,P2,ASYMP(20),I,
  1425.      +          N,ADTYPE(20),ACHLEN(20),STATUS
  1426.  
  1427.         LOGICAL COMPAT
  1428.  
  1429.         INTEGER ZYDOWN,ZYNEXT,ZYXGDT,ZYXGVA
  1430.         EXTERNAL ZYDOWN,ZYNEXT,ZYXGDT,ZYXGVA,ZYGTSY,ZYXSFA
  1431.  
  1432.         SYMPTR=-ZYDOWN(NODE)
  1433.         CALL ZYGTSY(SYMPTR,SYMBOL)
  1434.         PTR=ZYNEXT(NODE)
  1435.         P2=ZYDOWN(PTR)
  1436.         N=0
  1437.  
  1438.  100    N=N+1
  1439.         ASYMP(N)=-ZYDOWN(P2)
  1440.         DO 200 I=1,N-1
  1441.             IF (ASYMP(I).EQ.ASYMP(N)) THEN
  1442.                 CALL ERRMES('Duplicate statement fn dummy arguments',
  1443.      +                      -1)
  1444.                 RETURN
  1445.             END IF
  1446.  200    CONTINUE
  1447.         CALL EXPR(P2,.FALSE.,0,STATUS)
  1448.         IF (STATUS.EQ.-1) RETURN
  1449.         ADTYPE(N)=ZYXGDT(P2)
  1450.         IF (ADTYPE(N).EQ.6) THEN
  1451.             ACHLEN(N)=ZYXGVA(P2)
  1452.             IF (ACHLEN(N).LT.1) THEN
  1453.                 CALL ERRMES('Illegal 97 len spec for stmt fn dummy',
  1454.      +                      -1)
  1455.                 RETURN
  1456.             END IF
  1457.         ELSE
  1458.             ACHLEN(N)=0
  1459.         END IF
  1460.         P2=ZYNEXT(P2)
  1461.         IF (P2.NE.0) GOTO 100
  1462.  
  1463.         CALL ZYXSFA(SYMPTR,N,ADTYPE,ACHLEN)
  1464.  
  1465.         PTR=ZYNEXT(PTR)
  1466.         CALL EXPR(PTR,.FALSE.,SYMPTR*1000,STATUS)
  1467.         IF (STATUS.NE.-1) THEN
  1468.             IF (.NOT.COMPAT(ZYXGDT(PTR),SYMBOL(4)))
  1469.      +          CALL ERRMES('Incompatible types in stmt fn',-1)
  1470.         END IF
  1471.  
  1472.         END
  1473. C ----------------------------------------------------------------------
  1474. C
  1475. C       P R O A S S   -   Process ASSIGN statement
  1476. C
  1477.  
  1478.         SUBROUTINE PROASS(NODE)
  1479.         INTEGER NODE
  1480.  
  1481.         INTEGER SYMBOL(8)
  1482.  
  1483.         INTEGER ZYDOWN,ZYNEXT
  1484.         EXTERNAL ZYDOWN,ZYNEXT,ZYGTSY
  1485.  
  1486.         CALL ZYGTSY(-ZYDOWN(ZYNEXT(NODE)),SYMBOL)
  1487.         IF (SYMBOL(7).NE.0 .OR.
  1488.      +      SYMBOL(4).NE.1)
  1489.      +      CALL ERRMES('ASSIGN variable must be integer scalar',-1)
  1490.  
  1491.         END
  1492. C ----------------------------------------------------------------------
  1493. C
  1494. C       P R O C A L   -   Process a CALL statement
  1495. C
  1496.  
  1497.         SUBROUTINE PROCAL(NODE)
  1498.         INTEGER NODE
  1499.  
  1500.         COMMON/DOSTK/DOLVL,DOLBL,DOIDX
  1501.         INTEGER DOLVL,DOLBL(25),DOIDX(25)
  1502.  
  1503.         COMMON/CONTXT/PUN,STMTNO
  1504.         INTEGER PUN,STMTNO
  1505.  
  1506.         SAVE /CONTXT/,/DOSTK/
  1507.  
  1508.         INTEGER PTR,STATUS,TMP,ARGNUM,I
  1509.  
  1510.         INTEGER ZYDOWN,ZYNEXT,ZYUP,ZYNTYP,ZYXPAS
  1511.         EXTERNAL ZYDOWN,ZYNEXT,ZYUP,ZYNTYP,ZYXPAS,ZYXSUD
  1512.  
  1513.         PTR=NODE
  1514.  100    PTR=ZYNEXT(PTR)
  1515.         IF (PTR.NE.0) THEN
  1516.             CALL EXPR(PTR,.FALSE.,0,STATUS)
  1517.             IF (STATUS.EQ.-1) RETURN
  1518.             GOTO 100
  1519.         END IF
  1520.         IF (ZYXPAS(ZYUP(NODE),.FALSE.,STMTNO).EQ.-1) THEN
  1521.             CALL ERRMES('Inconsistent argument lists',-1)
  1522.         ELSE IF (DOLVL.GT.0) THEN
  1523.             PTR=ZYNEXT(NODE)
  1524.             ARGNUM=0
  1525.  200        IF (PTR.NE.0) THEN
  1526.                 TMP=-ZYDOWN(PTR)
  1527.                 ARGNUM=ARGNUM+1
  1528.                 DO 300 I=1,DOLVL
  1529.                     IF (TMP.EQ.DOIDX(I)) THEN
  1530.                         IF (ZYNTYP(PTR).EQ.108) THEN
  1531.                             CALL ZYXSUD(-ZYDOWN(NODE),
  1532.      +                                        ARGNUM,STMTNO)
  1533.                         END IF
  1534.                     END IF
  1535.  300            CONTINUE
  1536.                 PTR=ZYNEXT(PTR)
  1537.                 GOTO 200
  1538.             END IF
  1539.         END IF
  1540.  
  1541.         END
  1542. C ----------------------------------------------------------------------
  1543. C
  1544. C       P R O R E T   -   Process a RETURN statement
  1545. C
  1546.  
  1547.         SUBROUTINE PRORET(NODE)
  1548.         INTEGER NODE
  1549.  
  1550.         INTEGER STATUS
  1551.  
  1552.         INTEGER ZYXGDT,ZYNTYP,ZYUP
  1553.         EXTERNAL ZYXGDT,ZYNTYP,ZYUP
  1554.  
  1555.         IF (NODE.NE.0) THEN
  1556.             IF (ZYNTYP(ZYUP(ZYUP(NODE))).EQ.56) THEN
  1557.               IF (ZYNTYP(ZYUP(ZYUP(ZYUP(NODE)))).NE.4) THEN
  1558.                   CALL ERRMES('Alternate RETURN only allowed '//
  1559.      +                        'in SUBROUTINE',-1)
  1560.                   RETURN
  1561.               ENDIF
  1562.             ELSE IF (ZYNTYP(ZYUP(ZYUP(NODE))).NE.4) THEN
  1563.                 CALL ERRMES('Alternate RETURN only allowed '//
  1564.      +                      'in SUBROUTINE',-1)
  1565.                 RETURN
  1566.             END IF
  1567.             CALL EXPR(NODE,.FALSE.,0,STATUS)
  1568.             IF (STATUS.EQ.-1) RETURN
  1569.             IF (ZYXGDT(NODE).NE.1)
  1570.      +          CALL ERRMES('RETURN expression must be of type integer',
  1571.      +                      -1)
  1572.         END IF
  1573.  
  1574.         END
  1575. C ----------------------------------------------------------------------
  1576. C
  1577. C       P R O S U B   -   Process subroutine/function/entry statement
  1578. C
  1579.  
  1580.         SUBROUTINE PROSUB(NODE)
  1581.         INTEGER NODE
  1582.  
  1583.         INTEGER PTR,SYMPTR,NARGS,ARGLST(160),I,J
  1584.  
  1585.         INTEGER ZYDOWN,ZYNEXT,ZYNTYP
  1586.         EXTERNAL ZYDOWN,ZYNEXT,ZYNTYP,ZYXSPA
  1587.  
  1588.         SYMPTR=-ZYDOWN(NODE)
  1589.         NARGS=0
  1590.         PTR=ZYNEXT(NODE)
  1591.         IF (PTR.NE.0) PTR=ZYDOWN(PTR)
  1592.  
  1593.  100    IF (PTR.NE.0) THEN
  1594.             NARGS=NARGS+1
  1595.             IF (NARGS.GT.160) THEN
  1596.                 CALL ERRMES('Too many dummy arguments',-1)
  1597.                 RETURN
  1598.             END IF
  1599.             IF (ZYNTYP(PTR).EQ.108) THEN
  1600.                 ARGLST(NARGS)=-ZYDOWN(PTR)
  1601.             ELSE
  1602.                 ARGLST(NARGS)=-NARGS
  1603.             END IF
  1604.             PTR=ZYNEXT(PTR)
  1605.             GOTO 100
  1606.         END IF
  1607.         DO 300 I=1,NARGS-1
  1608.             DO 200 J=I+1,NARGS
  1609.                 IF (ARGLST(I).EQ.ARGLST(J)) THEN
  1610.                     CALL ERRMES('Duplicate dummy arguments',-1)
  1611.                     RETURN
  1612.                 END IF
  1613.  200        CONTINUE
  1614.  300    CONTINUE
  1615.         CALL ZYXSPA(SYMPTR,NARGS,ARGLST)
  1616.  
  1617.         END
  1618. C ----------------------------------------------------------------------
  1619. C
  1620. C       P R O A I F   -   Process arithmetic IF statement
  1621. C
  1622.  
  1623.         SUBROUTINE PROAIF(NODE)
  1624.         INTEGER NODE
  1625.  
  1626.         INTEGER STATUS,BITS,DTYPE
  1627.  
  1628.         INTEGER ZYXGDT,ZYXGTB,ZIAND
  1629.         EXTERNAL ZYXGDT,ZYXGTB,ZIAND
  1630.  
  1631.         STATUS=-2
  1632.         CALL EXPR(NODE,.FALSE.,0,STATUS)
  1633.         IF (STATUS.EQ.-2) THEN
  1634.             DTYPE=ZYXGDT(NODE)
  1635.             IF (DTYPE.NE.1 .AND. DTYPE.NE.14 .AND.
  1636.      +          DTYPE.NE.2 .AND. DTYPE.NE.5 .AND.
  1637.      +          DTYPE.NE.15) THEN
  1638.                 CALL ERRMES('Wrong expression type in arithmetic IF',
  1639.      +                      -1)
  1640.             ELSE
  1641.                 BITS=ZYXGTB(NODE)
  1642.                 IF (ZIAND(BITS,4194304+8388608).NE.0) THEN
  1643.                     CALL ERRMES('Arithmetic IF expr is array/proc',-1)
  1644.                 ELSE IF (ZIAND(BITS,2097152).NE.0) THEN
  1645.                     CALL ERRMES('Arithmetic IF expression is constant',
  1646.      +                          -2)
  1647.                 END IF
  1648.             END IF
  1649.         END IF
  1650.  
  1651.         END
  1652. C ----------------------------------------------------------------------
  1653. C
  1654. C       P R O P A U   -   Process a PAUSE or STOP statement
  1655. C
  1656.  
  1657.         SUBROUTINE PROPAU(NODE)
  1658.         INTEGER NODE
  1659.  
  1660.         INTEGER NTYPE,TEXT(134),STATUS
  1661.  
  1662.         INTEGER ZYNTYP,ZYDOWN,LENGTH
  1663.         EXTERNAL ZYNTYP,ZYDOWN,LENGTH
  1664.  
  1665.         IF (NODE.NE.0) THEN
  1666.             NTYPE=ZYNTYP(NODE)
  1667.             IF (NTYPE.EQ.107) THEN
  1668.                 CALL ZYGTST(-ZYDOWN(NODE),TEXT)
  1669.                 IF (LENGTH(TEXT).GT.5)
  1670.      +              CALL ERRMES('Too many digits in STOP/PAUSE code',
  1671.      +                          -1)
  1672.             ELSE IF (NTYPE.NE.114) THEN
  1673.                 CALL ERRMES('PROPAU: CORRUPT PARSE TREE',-1001)
  1674.             END IF
  1675.             CALL EXPR(NODE,.TRUE.,0,STATUS)
  1676.         END IF
  1677.  
  1678.         END
  1679. C ----------------------------------------------------------------------
  1680. C
  1681. C       P R O S A V   -   Process a SAVE statement
  1682. C
  1683.  
  1684.         SUBROUTINE PROSAV(NODE,MAIN)
  1685.         INTEGER NODE
  1686.         LOGICAL MAIN
  1687.  
  1688.         COMMON/CONTXT/PUN,STMTNO
  1689.         INTEGER PUN,STMTNO
  1690.  
  1691.         INTEGER PTR,SYMBOL(8),SPTR,STATUS
  1692.  
  1693.         SAVE /CONTXT/
  1694.  
  1695.         INTEGER ZYNEXT,ZYNTYP,ZYDOWN,ZIAND,ZYGNSW
  1696.         EXTERNAL ZYNEXT,ZYNTYP,ZYDOWN,ZIAND,ZYGNSW,ZYGTSY,ZYSATT
  1697.  
  1698.         PTR=NODE
  1699.         IF (PTR.EQ.0) THEN
  1700.             IF (MAIN) RETURN
  1701.             SPTR=0
  1702.  100        STATUS=ZYGNSW(SPTR,PUN,SYMBOL)
  1703.             IF (STATUS.EQ.-100) RETURN
  1704.             IF (SYMBOL(1).EQ.2)
  1705.      +          CALL ZYSATT(SPTR,8,3)
  1706.             GOTO 100
  1707.         END IF
  1708.  200    CALL ZYGTSY(-ZYDOWN(PTR),SYMBOL)
  1709.         IF (ZYNTYP(PTR).EQ.108) THEN
  1710.             IF (ZIAND(SYMBOL(6),4).NE.0)
  1711.      +          CALL ERRMES('Dummy argument in SAVE statement',-1)
  1712.             IF (ZIAND(SYMBOL(6),1024).NE.0)
  1713.      +          CALL ERRMES('Common block item in SAVE statement',-1)
  1714.             IF (SYMBOL(1).EQ.4)
  1715.      +          CALL ERRMES('Program-unit name in SAVE statement',-1)
  1716.             IF (SYMBOL(1).EQ.9)
  1717.      +          CALL ERRMES('Entry point name in SAVE statement',-1)
  1718.         ELSE
  1719.             CALL ZYSATT(-ZYDOWN(PTR),8,3)
  1720.         END IF
  1721.         PTR=ZYNEXT(PTR)
  1722.         IF (PTR.NE.0) GOTO 200
  1723.  
  1724.         END
  1725. C ----------------------------------------------------------------------
  1726. C
  1727. C       P R O F M T   -   Process a FORMAT statement
  1728. C
  1729.  
  1730.         SUBROUTINE PROFMT(NODE)
  1731.         INTEGER NODE
  1732.  
  1733.         INTEGER PTR,STATUS,NTYPE,NEXT,DEPTH
  1734.  
  1735.         INTEGER ZYNTYP,ZYNEXT,ZYDOWN,ZYUP
  1736.         EXTERNAL ZYNTYP,ZYNEXT,ZYDOWN,ZYUP
  1737.  
  1738.         PTR=NODE
  1739.         IF (PTR.EQ.0) RETURN
  1740.         STATUS=-2
  1741.         DEPTH=0
  1742.  100    NTYPE=ZYNTYP(PTR)
  1743.         IF (NTYPE.EQ.117 .OR. NTYPE.EQ.79) THEN
  1744.             NEXT=ZYDOWN(PTR)
  1745.             DEPTH=DEPTH+1
  1746.         ELSE
  1747.             IF (NTYPE.EQ.114 .OR. NTYPE.EQ.113) THEN
  1748.                 CALL EXPR(PTR,.FALSE.,0,STATUS)
  1749.                 IF (STATUS.EQ.-1) RETURN
  1750.             END IF
  1751.  200        NEXT=ZYNEXT(PTR)
  1752.             IF (NEXT.EQ.0 .AND. DEPTH.GT.0) THEN
  1753.                 PTR=ZYUP(PTR)
  1754.                 DEPTH=DEPTH-1
  1755.                 GOTO 200
  1756.             END IF
  1757.         END IF
  1758.         PTR=NEXT
  1759.         IF (PTR.NE.0) GOTO 100
  1760.  
  1761.         END
  1762. C ----------------------------------------------------------------------
  1763. C
  1764. C       I N I D I D   -   Initialise data_implied_do handling
  1765. C
  1766. C       D I D   -   enter a data_implied_do loop
  1767. C
  1768. C       E N D D I D   -   end a data_implied_do loop
  1769. C
  1770.  
  1771.         SUBROUTINE INIDID
  1772.         INTEGER PTRI,STATUS
  1773.  
  1774.         COMMON/DIDCMN/SP,IDOSTK
  1775.         INTEGER SP,IDOSTK(5,25)
  1776.  
  1777.         INTEGER PTR,I
  1778.  
  1779.         SAVE /DIDCMN/
  1780.  
  1781.         INTEGER ZYDOWN,ZYPREV,ZYNEXT,ZYUP,ZYXGVA,ZYXGDT
  1782.         EXTERNAL ZYDOWN,ZYPREV,ZYNEXT,ZYUP,ZYXGVA,ZYXGDT
  1783.  
  1784. C
  1785. C IDOSTK:   1 = index symbol pointer
  1786. C           2 = current value
  1787. C           3 = upper bound
  1788. C           4 = step value
  1789. C           5 = first subnode
  1790. C
  1791.  
  1792.         SP=0
  1793.         RETURN
  1794.  
  1795.         ENTRY DID(PTRI,STATUS)
  1796.  
  1797.         IF (SP.EQ.25) THEN
  1798.             CALL ERRMES('DATA-implied DO stack overflow',-1)
  1799.             STATUS=-1
  1800.             RETURN
  1801.         END IF
  1802.         PTRI=ZYDOWN(PTRI)
  1803.         IDOSTK(5,SP+1)=PTRI
  1804.         PTR=ZYDOWN(ZYPREV(PTRI))
  1805.         IDOSTK(1,SP+1)=-ZYDOWN(PTR)
  1806.         DO 100 I=1,SP-1
  1807.             IF (IDOSTK(1,I).EQ.IDOSTK(1,SP+1)) THEN
  1808.                 CALL ERRMES('Duplicate DATA-implied DO loop variable',
  1809.      +                      -1)
  1810.                 STATUS=-1
  1811.                 RETURN
  1812.             END IF
  1813.  100    CONTINUE
  1814.         PTR=ZYNEXT(PTR)
  1815.         CALL EXPR(PTR,.TRUE.,1,STATUS)
  1816.         IF (STATUS.EQ.-1) RETURN
  1817.         IF (ZYXGDT(PTR).NE.1) THEN
  1818.             CALL ERRMES('Limit expression must be integer',-1)
  1819.             STATUS=-1
  1820.             RETURN
  1821.         END IF
  1822.         IDOSTK(2,SP+1)=ZYXGVA(PTR)
  1823.         PTR=ZYNEXT(PTR)
  1824.         CALL EXPR(PTR,.TRUE.,1,STATUS)
  1825.         IF (STATUS.EQ.-1) RETURN
  1826.         IF (ZYXGDT(PTR).NE.1) THEN
  1827.             CALL ERRMES('Limit expression must be integer',-1)
  1828.             STATUS=-1
  1829.             RETURN
  1830.         END IF
  1831.         IDOSTK(3,SP+1)=ZYXGVA(PTR)
  1832.         IDOSTK(4,SP+1)=1
  1833.         PTR=ZYNEXT(PTR)
  1834.         IF (PTR.NE.0) THEN
  1835.             CALL EXPR(PTR,.TRUE.,1,STATUS)
  1836.             IF (STATUS.EQ.-1) RETURN
  1837.             IF (ZYXGDT(PTR).NE.1) THEN
  1838.                 CALL ERRMES('Limit expression must be integer',-1)
  1839.                 STATUS=-1
  1840.                 RETURN
  1841.             END IF
  1842.             IDOSTK(4,SP+1)=ZYXGVA(PTR)
  1843.         END IF
  1844.         SP=SP+1
  1845.         RETURN
  1846.  
  1847.         ENTRY ENDDID(PTRI,STATUS)
  1848.  
  1849.         IDOSTK(2,SP)=IDOSTK(2,SP)+IDOSTK(4,SP)
  1850.         IF (IDOSTK(2,SP).LE.IDOSTK(3,SP)) THEN
  1851.             PTRI=IDOSTK(5,SP)
  1852.         ELSE
  1853.             SP=SP-1
  1854.             PTRI=ZYNEXT(ZYUP(PTRI))
  1855.         END IF
  1856.  
  1857.         END
  1858. C ----------------------------------------------------------------------
  1859. C
  1860. C       E V D V A R   -   Evaluate Data_implied_do_loop variable
  1861. C
  1862.  
  1863.         SUBROUTINE EVDVAR(SYMPTR,VALUE,STATUS)
  1864.         INTEGER SYMPTR,VALUE,STATUS
  1865.  
  1866.         COMMON/DIDCMN/SP,IDOSTK
  1867.         INTEGER SP,IDOSTK(5,25)
  1868.  
  1869.         INTEGER I
  1870.  
  1871.         SAVE /DIDCMN/
  1872.  
  1873.         DO 100 I=1,SP
  1874.             IF (SYMPTR.EQ.IDOSTK(1,I)) THEN
  1875.                 VALUE=IDOSTK(2,I)
  1876.                 RETURN
  1877.             END IF
  1878.  100    CONTINUE
  1879.         CALL ERRMES('Invalid item expr in DATA statement',-1)
  1880.         STATUS=-1
  1881.  
  1882.         END
  1883. C ----------------------------------------------------------------------
  1884. C
  1885. C       D V I N I T   -   Initialise data-value reader
  1886. C
  1887. C       D V   -   Read some data values
  1888. C
  1889.  
  1890.         SUBROUTINE DVINIT(NODE,SNODE)
  1891.         INTEGER NODE,SNODE,IDTYPE,NITEMS
  1892.  
  1893.         INTEGER PTR,DTYPE,NVALS,STATUS,P1,P2,COUNT,STNODE
  1894.  
  1895.         SAVE
  1896.  
  1897.         INTEGER ZYNTYP,ZYDOWN,ZYNEXT,ZYXGVA,ZYXGDT
  1898.         EXTERNAL ZYNTYP,ZYDOWN,ZYNEXT,ZYXGVA,ZYXGDT,ZYXSTB
  1899.  
  1900.         PTR=NODE
  1901.         STNODE=SNODE
  1902.         NVALS=0
  1903.         RETURN
  1904.  
  1905.         ENTRY DV(IDTYPE,NITEMS)
  1906.  
  1907.         COUNT=NITEMS
  1908.  
  1909.  100    IF (NVALS.EQ.0) THEN
  1910.             IF (PTR.EQ.0) THEN
  1911.                 CALL ERRMES('Insufficient DATA values',-1)
  1912.                 RETURN
  1913.             END IF
  1914.             IF (ZYNTYP(PTR).EQ.45) THEN
  1915.                 P1=ZYDOWN(PTR)
  1916.                 P2=ZYNEXT(P1)
  1917.                 CALL EXPR(P1,.TRUE.,0,STATUS)
  1918.                 CALL EXPR(P2,.TRUE.,0,STATUS)
  1919.                 IF (STATUS.EQ.-1) RETURN
  1920.                 NVALS=ZYXGVA(P1)
  1921.                 IF (NVALS.LT.1) THEN
  1922.                     CALL ERRMES('Invalid repetition count',-1)
  1923.                     RETURN
  1924.                 END IF
  1925.                 DTYPE=ZYXGDT(P2)
  1926.             ELSE
  1927.                 CALL EXPR(PTR,.TRUE.,0,STATUS)
  1928.                 IF (STATUS.EQ.-1) RETURN
  1929.                 NVALS=1
  1930.                 DTYPE=ZYXGDT(PTR)
  1931.                 P2=PTR
  1932.             END IF
  1933.         END IF
  1934.         IF (DTYPE.NE.IDTYPE) THEN
  1935.             CALL ZYXSTB(STNODE,16777216)
  1936.             IF ((DTYPE.NE.9 .OR. IDTYPE.NE.1 .AND.
  1937.      +          IDTYPE.NE.2 .AND. IDTYPE.NE.3) .AND.
  1938.      +          (DTYPE.NE.1 .AND. DTYPE.NE.2 .AND.
  1939.      +          DTYPE.NE.5 .AND. DTYPE.NE.15  .AND.
  1940.      +          DTYPE.NE.14 .OR.
  1941.      +          IDTYPE.NE.1 .AND. IDTYPE.NE.2 .AND.
  1942.      +          IDTYPE.NE.5 .AND. IDTYPE.NE.15 .AND.
  1943.      +          IDTYPE.NE.14) .AND.
  1944.      +          (DTYPE.NE.4 .AND. DTYPE.NE.7 .OR.
  1945.      +          IDTYPE.NE.4 .AND. IDTYPE.NE.7)) THEN
  1946.                CALL ERRMES('Incompatible types in DATA',-1)
  1947.             ELSE IF (DTYPE.EQ.9) THEN
  1948.                 IF (ZYXGVA(P2).GT.4)
  1949.      +              CALL ERRMES('Hollerith constant too long',-1)
  1950.             END IF
  1951.         END IF
  1952.         COUNT=COUNT-NVALS
  1953.         IF (COUNT.GE.0) THEN
  1954.             NVALS=0
  1955.             PTR=ZYNEXT(PTR)
  1956.             IF (COUNT.GT.0) GOTO 100
  1957.         ELSE
  1958.             NVALS=-COUNT
  1959.         END IF
  1960.         RETURN
  1961.  
  1962.         ENTRY DVEND
  1963.         IF (PTR.NE.0) CALL ERRMES('Too many DATA values',-1)
  1964.  
  1965.         END
  1966. C ----------------------------------------------------------------------
  1967. C
  1968. C       A R R A Y D   -   Process an array_declarator
  1969. C
  1970.  
  1971.         SUBROUTINE ARRAYD(NODE)
  1972.         INTEGER NODE
  1973.  
  1974.         INTEGER PTR,N,LOW(10),UPPER(10),STATUS,
  1975.      +          SYMBOL(8),SYMPTR
  1976.         LOGICAL ADJP,INFP,TMPP
  1977.  
  1978.         INTEGER ZYXGVA,ZYDOWN,ZYNEXT,ZYNTYP,ZIAND
  1979.         EXTERNAL ZYXGVA,ZYDOWN,ZYNEXT,ZYNTYP,ZIAND,ZYXSAD
  1980.  
  1981.         PTR=ZYNEXT(ZYDOWN(NODE))
  1982.         SYMPTR=-ZYDOWN(ZYDOWN(NODE))
  1983.         ADJP=.FALSE.
  1984.         INFP=.FALSE.
  1985.         N=1
  1986.         STATUS=-2
  1987.  100    IF (ZYNTYP(PTR).EQ.23) THEN
  1988.             INFP=.TRUE.
  1989.             IF (ZYDOWN(PTR).EQ.0) THEN
  1990.                 LOW(N)=1
  1991.             ELSE
  1992.                 TMPP=.FALSE.
  1993.                 CALL ARDIM2(ZYDOWN(PTR),LOW(N),TMPP,STATUS)
  1994.                 IF (STATUS.EQ.-1) RETURN
  1995.                 IF (TMPP) THEN
  1996.                     ADJP=.TRUE.
  1997.                     UPPER(N)=LOW(N)-1
  1998.                 ELSE
  1999.                     UPPER(N)=LOW(N)
  2000.                 END IF
  2001.             END IF
  2002.         ELSE
  2003.             CALL ARDIM(PTR,LOW(N),UPPER(N),ADJP,STATUS)
  2004.         END IF
  2005.         IF (STATUS.NE.-2) RETURN
  2006.         PTR=ZYNEXT(PTR)
  2007.         IF (PTR.NE.0) THEN
  2008.             N=N+1
  2009.             IF (N.LE.10) GOTO 100
  2010.             CALL ERRSYM('Too many dimensions in array ',SYMPTR,-1)
  2011.         ELSE IF (N.GT.7) THEN
  2012.             CALL ERRSYM('Non-standard numb'//'er of dimensions for ',
  2013.      +                  SYMPTR,-1)
  2014.         END IF
  2015.         CALL ZYXSAD(SYMPTR,N,LOW,UPPER,ADJP,INFP)
  2016.  
  2017.         END
  2018. C ----------------------------------------------------------------------
  2019. C
  2020. C       A R D I M   -   Evaluate array dimensions
  2021. C
  2022.  
  2023.         SUBROUTINE ARDIM(NODE,LOW,HIGH,ADJP,STATUS)
  2024.         INTEGER NODE,LOW,HIGH,STATUS
  2025.         LOGICAL ADJP
  2026.  
  2027.         INTEGER TMP,PTR
  2028.  
  2029.         INTEGER ZYDOWN,ZYNEXT
  2030.         EXTERNAL ZYDOWN,ZYNEXT
  2031.  
  2032.         PTR=ZYDOWN(NODE)
  2033.         CALL ARDIM2(PTR,TMP,ADJP,STATUS)
  2034.         IF (STATUS.NE.-2) RETURN
  2035.         PTR=ZYNEXT(PTR)
  2036.         IF (PTR.EQ.0) THEN
  2037.             HIGH=TMP
  2038.             LOW=1
  2039.         ELSE
  2040.             LOW=TMP
  2041.             CALL ARDIM2(PTR,HIGH,ADJP,STATUS)
  2042.         END IF
  2043.  
  2044.         END
  2045. C ----------------------------------------------------------------------
  2046. C
  2047. C       A R D I M 2   -   Evaluate a single array dimension
  2048. C
  2049.  
  2050.         SUBROUTINE ARDIM2(NODE,LIMIT,ADJP,STATUS)
  2051.         INTEGER NODE,LIMIT,STATUS
  2052.         LOGICAL ADJP
  2053.  
  2054.         INTEGER ZIAND,ZYXGTB,ZYXGDT,ZYXGVA
  2055.         EXTERNAL ZIAND,ZYXGTB,ZYXGDT,ZYXGVA
  2056.  
  2057.         CALL EXPR(NODE,.FALSE.,2,STATUS)
  2058.         IF (STATUS.EQ.-2) THEN
  2059.             IF (ZIAND(ZYXGTB(NODE),2097152).EQ.0) THEN
  2060.                 ADJP=.TRUE.
  2061.                 LIMIT=0
  2062.             ELSE IF (ZYXGDT(NODE).NE.1) THEN
  2063.                 CALL ERRMES('Array declarator expr of wrong type',-1)
  2064.                 STATUS=-1
  2065.             ELSE
  2066.                 LIMIT=ZYXGVA(NODE)
  2067.             END IF
  2068.         END IF
  2069.  
  2070.         END
  2071. C ----------------------------------------------------------------------
  2072. C
  2073. C       F M T I D   -   Process a format_identifier
  2074. C
  2075.  
  2076.         SUBROUTINE FMTID(NODE,STATUS)
  2077.         INTEGER NODE,STATUS
  2078.  
  2079.         INTEGER PTR,NTYPE,DTYPE,ARGN,SYMBOL(8)
  2080.         LOGICAL BADTYP
  2081.  
  2082.         LOGICAL ARRAYP,PROCP
  2083.  
  2084.         INTEGER ZYDOWN,ZYNTYP,ZYXGDT,ZIAND,ZYXGTB
  2085.         EXTERNAL ZYDOWN,ZYNTYP,ZYXGDT,ZIAND,ZYXGTB,ZYGTSY
  2086.  
  2087.         ARRAYP(ARGN)=ZIAND(ZYXGTB(ARGN),4194304).NE.0
  2088.         PROCP(ARGN)=ZIAND(ZYXGTB(ARGN),8388608).NE.0
  2089.  
  2090.         PTR=ZYDOWN(NODE)
  2091.         NTYPE=ZYNTYP(PTR)
  2092.         IF (NTYPE.NE.116 .AND. NTYPE.NE.17) THEN
  2093.             CALL EXPR(PTR,.FALSE.,0,STATUS)
  2094.             IF (STATUS.EQ.-1) RETURN
  2095.             DTYPE=ZYXGDT(PTR)
  2096.             BADTYP=DTYPE.NE.6
  2097.             IF (DTYPE.EQ.1 .OR. DTYPE.EQ.2 .OR.
  2098.      +          DTYPE.EQ.3 .OR. DTYPE.EQ.12 .OR.
  2099.      +          DTYPE.EQ.13) BADTYP=.NOT.ARRAYP(PTR)
  2100.             IF (NTYPE.EQ.108 .AND. DTYPE.EQ.1 .AND.
  2101.      +          BADTYP) THEN
  2102.                 CALL ZYGTSY(-ZYDOWN(PTR),SYMBOL)
  2103.                 BADTYP=ZIAND(SYMBOL(6),16).EQ.0
  2104.             END IF
  2105.             IF (BADTYP) THEN
  2106.                 CALL ERRMES('Incorrect type of format expression',-1)
  2107.                 STATUS=-1
  2108.             ELSE IF (PROCP(PTR)) THEN
  2109.                 CALL ERRMES('Format expression is procedure',-1)
  2110.                 STATUS=-1
  2111.             END IF
  2112.         END IF
  2113.  
  2114.         END
  2115. C ----------------------------------------------------------------------
  2116. C
  2117. C       I O L I S T   -   Process an i/o list
  2118. C
  2119.  
  2120.         SUBROUTINE IOLIST(NODE)
  2121.         INTEGER NODE
  2122.  
  2123.         INTEGER PTR,NTYPE,SYMBOL(8),P2,STATUS,SP,
  2124.      +          IDOSTK(2,25),I
  2125.  
  2126.         INTEGER ZYNEXT,ZYDOWN,ZYNTYP,ZYPREV
  2127.         EXTERNAL ZYNEXT,ZYDOWN,ZYPREV,ZYGTSY,ZYNTYP
  2128.  
  2129.         PTR=NODE
  2130.         SP=0
  2131.  
  2132.  100    NTYPE=ZYNTYP(PTR)
  2133.         IF (NTYPE.EQ.108) THEN
  2134.             CALL EXPR(PTR,.FALSE.,0,STATUS)
  2135.             IF (STATUS.EQ.-1) RETURN
  2136.             CALL ZYGTSY(-ZYDOWN(PTR),SYMBOL)
  2137.             IF (SYMBOL(1).EQ.5 .AND.
  2138.      +          SYMBOL(7).NE.0) THEN
  2139.                 P2=ZYDOWN(SYMBOL(7))
  2140.  200            IF (ZYNTYP(P2).EQ.23) THEN
  2141.                     CALL ERRMES('Unsubscripted assumed-size array '//
  2142.      +                          'in i-o list',-1)
  2143.                     RETURN
  2144.                 END IF
  2145.                 P2=ZYNEXT(P2)
  2146.                 IF (P2.NE.0) GOTO 200
  2147.             END IF
  2148.         ELSE IF (NTYPE.EQ.71) THEN
  2149.             IF (SP.EQ.25)
  2150.      +          CALL ERRMES('i/o implied do nesting limit exceeded',
  2151.      +                      -1001)
  2152.             SP=SP+1
  2153.             IDOSTK(1,SP)=ZYNEXT(PTR)
  2154.             PTR=ZYDOWN(PTR)
  2155.             IDOSTK(2,SP)=-ZYDOWN(ZYDOWN(ZYPREV(PTR)))
  2156.             DO 300 I=1,SP-1
  2157.                 IF (IDOSTK(2,I).EQ.IDOSTK(2,SP)) THEN
  2158.                     CALL ERRMES('Duplicate control vars in nested '//
  2159.      +                          'implied do loops',-1)
  2160.                     RETURN
  2161.                 END IF
  2162.  300        CONTINUE
  2163.             GOTO 100
  2164.         ELSE
  2165.             CALL EXPR(PTR,.FALSE.,0,STATUS)
  2166.             IF (STATUS.EQ.-1) RETURN
  2167.         END IF
  2168.         PTR=ZYNEXT(PTR)
  2169.         IF (PTR.NE.0) GOTO 100
  2170.         IF (SP.GT.0) THEN
  2171.             PTR=IDOSTK(1,SP)
  2172.             SP=SP-1
  2173.             IF (PTR.NE.0) GOTO 100
  2174.         END IF
  2175.  
  2176.         END
  2177. C ----------------------------------------------------------------------
  2178. C
  2179. C       C I L I S T   -   Process a control-information list
  2180. C
  2181.  
  2182.         SUBROUTINE CILIST(NODE,STATUS)
  2183.         INTEGER NODE,STATUS
  2184.  
  2185. C Note: 'NCII' & 'CIIFIL' must match NCII & CIIFIL in CIITEM, and
  2186. C       'UNITCI' must be the number of the UNIT= ciitem.
  2187.  
  2188.         INTEGER NCII,UNITCI,CIIFIL,CIIREC,CIIEND
  2189.         PARAMETER (NCII=21,UNITCI=21,CIIFIL=7,CIIREC=16,CIIEND=4)
  2190.  
  2191.         INTEGER PTR,NTYPE,P2,DTYPE,I,STYPE
  2192.         LOGICAL OCCURS(NCII),FMTOCC,LISDIR,INTFIL
  2193.  
  2194.         INTEGER ZYNEXT,ZYDOWN,ZYNTYP,ZIAND,ZYXGDT,ZYXGTB,ZYUP
  2195.         EXTERNAL ZYNEXT,ZYDOWN,ZYNTYP,ZIAND,ZYXGDT,ZYXGTB,ZYUP,
  2196.      +           ZYSABT
  2197.  
  2198.         LOGICAL PROCP,CONSTP
  2199.         INTEGER ARGN
  2200.  
  2201.         PROCP(ARGN)=ZIAND(ZYXGTB(ARGN),8388608).NE.0
  2202.         CONSTP(ARGN)=ZIAND(ZYXGTB(ARGN),2097152).NE.0
  2203.  
  2204.         PTR=ZYDOWN(NODE)
  2205.         DO 100 I=1,NCII
  2206.  100        OCCURS(I)=.FALSE.
  2207.         FMTOCC=.FALSE.
  2208.         LISDIR=.FALSE.
  2209.         INTFIL=.FALSE.
  2210.         STYPE=ZYNTYP(ZYUP(NODE))
  2211.  
  2212.  200    NTYPE=ZYNTYP(PTR)
  2213.         IF (NTYPE.EQ.122) THEN
  2214.             IF (OCCURS(UNITCI)) THEN
  2215.                 CALL ERRMES('Unit_identifier occurs twice',-1)
  2216.                 STATUS=-1
  2217.                 RETURN
  2218.             END IF
  2219.             OCCURS(UNITCI)=.TRUE.
  2220.             IF (ZYNTYP(ZYDOWN(PTR)).NE.17) THEN
  2221.                 P2=ZYDOWN(PTR)
  2222.                 CALL EXPR(P2,.FALSE.,0,STATUS)
  2223.                 IF (STATUS.EQ.-1) RETURN
  2224.                 DTYPE=ZYXGDT(P2)
  2225.                 IF (DTYPE.NE.1 .AND. DTYPE.NE.6) THEN
  2226.                     CALL ERRMES('Unit-id must be integer/97 string/*',
  2227.      +                          -1)
  2228.                     STATUS=-1
  2229.                     RETURN
  2230.                 ELSE IF (PROCP(P2)) THEN
  2231.                     CALL ERRMES('Unit-identifier is procedure',-1)
  2232.                     STATUS=-1
  2233.                     RETURN
  2234.                 ELSE IF (DTYPE.EQ.6) THEN
  2235.                     INTFIL=.TRUE.
  2236.                     IF (ZYNTYP(P2).NE.108 .AND.
  2237.      +                  ZYNTYP(P2).NE.104 .AND.
  2238.      +                  ZYNTYP(P2).NE.103 .OR.
  2239.      +                  CONSTP(P2)) THEN
  2240.                         CALL ERRMES(
  2241.      +'Internal file must be variable/array element/substring',-1)
  2242.                         STATUS=-1
  2243.                         RETURN
  2244.                     ELSE IF (STYPE.EQ.65) THEN
  2245. C Get symbol pointer (may have to go down two levels, for a substring
  2246. C of an array element
  2247.                         P2=ZYDOWN(P2)
  2248.                         IF (P2.GT.0) P2=ZYDOWN(P2)
  2249.                         IF (P2.GT.0) P2=ZYDOWN(P2)
  2250.                         IF (P2.GT.0)
  2251.      +                      CALL ERRMES('CILIST UNITID ERROR',-1001)
  2252. C Say it is modified...
  2253.                         CALL ZYSABT(-P2,6,32)
  2254. C Also make sure common block (if any) is marked as modified too
  2255.                         CALL UPDCOM(-P2)
  2256.                     ELSE IF (STYPE.NE.66) THEN
  2257.                         CALL ERRMES(
  2258.      +'Auxiliary i/o statement specifies an internal file',-1)
  2259.                         STATUS=-1
  2260.                         RETURN
  2261.                     END IF
  2262.                 END IF
  2263.             END IF
  2264.         ELSE IF (NTYPE.EQ.123) THEN
  2265.             IF (FMTOCC) THEN
  2266.                 CALL ERRMES('Format-identifier occurs twice',-1)
  2267.                 STATUS=-1
  2268.                 RETURN
  2269.             END IF
  2270.             CALL FMTID(PTR,STATUS)
  2271.             IF (STATUS.EQ.-1) RETURN
  2272.             LISDIR=ZYNTYP(ZYDOWN(PTR)).EQ.17
  2273.             FMTOCC=.TRUE.
  2274.         ELSE IF (NTYPE.EQ.69) THEN
  2275.             P2=ZYNEXT(ZYDOWN(PTR))
  2276.             NTYPE=ZYNTYP(P2)
  2277.             IF (NTYPE.NE.17) THEN
  2278.                 CALL EXPR(P2,.FALSE.,0,STATUS)
  2279.                 IF (STATUS.EQ.-1) RETURN
  2280.             END IF
  2281.             CALL CIITEM(PTR,OCCURS,STYPE,STATUS,INTFIL)
  2282.             IF (STATUS.EQ.-1) RETURN
  2283.         ELSE
  2284.             CALL ERRMES('CILIST: TREE IS CORRUPT',-1001)
  2285.         END IF
  2286.         PTR=ZYNEXT(PTR)
  2287.         IF (PTR.GT.0) GOTO 200
  2288.         IF ((STYPE.EQ.75 .OR. STYPE.EQ.76 .OR.
  2289.      +      STYPE.EQ.77 .OR. STYPE.EQ.65 .OR.
  2290.      +      STYPE.EQ.66) .AND. .NOT.OCCURS(UNITCI)) THEN
  2291.             CALL ERRMES('No unit-identifier in control-info list',
  2292.      +                  -1)
  2293.             STATUS=-1
  2294.         ELSE IF (STYPE.NE.65.AND.STYPE.NE.66.AND.FMTOCC) THEN
  2295.             CALL ERRMES('Format-identifier n'//'ot allowed here',-1)
  2296.             STATUS=-1
  2297.         ELSE IF (STYPE.EQ.74) THEN
  2298.             IF (OCCURS(UNITCI) .AND. OCCURS(CIIFIL)) THEN
  2299.                 CALL ERRMES('Both UNIT= a'//'nd FILE= in INQUIRE',-1)
  2300.                 STATUS=-1
  2301.             ELSE IF (.NOT.(OCCURS(UNITCI).OR.OCCURS(CIIFIL))) THEN
  2302.                 CALL ERRMES('Neither UNIT= 124 FILE= in INQUIRE',-1)
  2303.                 STATUS=-1
  2304.             END IF
  2305.         ELSE IF (LISDIR.AND.INTFIL) THEN
  2306.             CALL ERRMES('List-directed i/o used on internal file',-1)
  2307.             STATUS=-1
  2308.         ELSE IF (LISDIR.AND.OCCURS(CIIREC)) THEN
  2309.             CALL ERRMES('List-directed i/o used on direct-access file',
  2310.      +                  -1)
  2311.         ELSE IF (OCCURS(CIIREC).AND.OCCURS(CIIEND)) THEN
  2312.             CALL ERRMES('Both REC= an'//'d END= occur in c-i list',
  2313.      +                  -1)
  2314.         END IF
  2315.  
  2316.         END
  2317. C ----------------------------------------------------------------------
  2318. C
  2319. C       C I I T E M   -   Process a control-info list item
  2320. C
  2321.  
  2322.         SUBROUTINE CIITEM(NODE,OCCURS,STYPE,STATUS,INTFIL)
  2323.         INTEGER MAXL,NCII,CIIFIL,CIIERR
  2324.         PARAMETER (MAXL=11,NCII=21,CIIFIL=7,CIIERR=5)
  2325.  
  2326.         INTEGER NODE,STATUS,STYPE
  2327.         LOGICAL OCCURS(NCII),INTFIL
  2328.  
  2329.         CHARACTER*(*) UNKCII
  2330.         PARAMETER (UNKCII='Unknown control-info-list item n'//
  2331.      +                    'ot checked')
  2332.         LOGICAL T,F
  2333.         PARAMETER (T=.TRUE.,F=.FALSE.)
  2334.  
  2335.         INTEGER PTR,TEXT(134),CIINUM,TYPCHK,CIITYP(NCII),I,
  2336.      +          NTYPE,DTYPE,SYMBOL(8),SSTYPE(132)
  2337.         LOGICAL CIIAST(NCII),CIIVAR(NCII),CIISTY(8,NCII)
  2338.         CHARACTER*(MAXL) CIINAM,CIILST(NCII)
  2339.  
  2340.         SAVE CIILST,CIITYP,CIIAST,CIIVAR,CIISTY,SSTYPE
  2341.  
  2342.         INTEGER FIND,LENSTR
  2343.  
  2344.         INTEGER ZYNTYP,ZYDOWN,ZYNEXT,ZYXGDT,ZYXGTB,ZIAND,
  2345.      +          LENGTH
  2346.         EXTERNAL ZYNTYP,ZYDOWN,ZYNEXT,ZYXGDT,ZYXGTB,ZYGTST,
  2347.      +           ZIAND,LENGTH,ZITOF,ZYSABT
  2348.  
  2349.         LOGICAL BADP,PROCP,CONSTP
  2350.  
  2351.         BADP(I)=ZIAND(ZYXGTB(I),4194304+8388608).NE.0
  2352.         PROCP(I)=ZIAND(ZYXGTB(I),8388608).NE.0
  2353.         CONSTP(I)=ZIAND(ZYXGTB(I),2097152).NE.0
  2354.  
  2355.         DATA SSTYPE(65)/1/,
  2356.      +       SSTYPE(66)/2/,
  2357.      +       SSTYPE(72)/3/,
  2358.      +       SSTYPE(73)/4/,
  2359.      +       SSTYPE(74)/5/,
  2360.      +       SSTYPE(75)/6/,
  2361.      +       SSTYPE(76)/7/,
  2362.      +       SSTYPE(77)/8/
  2363.  
  2364. C Control-information-list item data:
  2365. C   Name  Asterisk  Data type  Must be     Ok in stmts:
  2366. C         ok?       0=int/char var/arelm?  WRITE,READ,OPEN,CLOSE,
  2367. C                                          INQUIRE,BACKSPACE,ENDFILE,
  2368. C                                          REWIND
  2369.  
  2370.         DATA (CIILST(I),CIIAST(I),CIITYP(I),CIIVAR(I),
  2371.      +        (CIISTY(J,I),J=1,8),I=1,18)/
  2372.      +'ACCESS',F,6,F,F,F,T,F,T,F,F,F,
  2373.      +'BLANK',F,6,F,F,F,T,F,T,F,F,F,
  2374.      +'DIRECT',F,6,T,F,F,F,F,T,F,F,F,
  2375.      +'END',F,10,F,F,T,F,F,F,F,F,F,
  2376.      +'ERR',F,10,F,T,T,T,T,T,T,T,T,
  2377.      +'EXIST',F,3,T,F,F,F,F,T,F,F,F,
  2378. C The parameter CIIFIL *must* be set to the array index for "FILE"
  2379.      +'FILE',F,6,F,F,F,T,F,T,F,F,F,
  2380.      +'FORM',F,6,F,F,F,T,F,T,F,F,F,
  2381.      +'FORMATTED',F,6,T,F,F,F,F,T,F,F,F,
  2382.      +'IOSTAT',F,1,T,T,T,T,T,T,T,T,T,
  2383.      +'NAME',F,6,T,F,F,F,F,T,F,F,F,
  2384.      +'NAMED',F,3,T,F,F,F,F,T,F,F,F,
  2385.      +'NEXTREC',F,1,T,F,F,F,F,T,F,F,F,
  2386.      +'NUMBER',F,1,T,F,F,F,F,T,F,F,F,
  2387.      +'OPENED',F,3,T,F,F,F,F,T,F,F,F,
  2388.      +'REC',F,1,F,T,T,F,F,F,F,F,F,
  2389.      +'RECL',F,1,F,F,F,T,F,T,F,F,F,
  2390.      +'SEQUENTIAL',F,6,T,F,F,F,F,T,F,F,F/
  2391.         DATA (CIILST(I),CIIAST(I),CIITYP(I),CIIVAR(I),
  2392.      +        (CIISTY(J,I),J=1,8),I=19,NCII)/
  2393.      +'STATUS',F,6,F,F,F,T,T,F,F,F,F,
  2394.      +'UNFORMATTED',F,6,T,F,F,F,F,T,F,F,F,
  2395.      +'UNIT',T,0,F,T,T,T,T,T,T,T,T/
  2396.  
  2397.         PTR=ZYDOWN(NODE)
  2398.         IF (ZYNTYP(PTR).NE.118) CALL ERRMES('CIITEM: TREE CORRUPT',
  2399.      +                                         -1001)
  2400.         CALL ZYGTST(-ZYDOWN(PTR),TEXT)
  2401.         CALL ZTOCAP(TEXT)
  2402.         PTR=ZYNEXT(PTR)
  2403.         IF (LENGTH(TEXT).GT.MAXL) THEN
  2404.             CALL ERRMES(UNKCII,-1002)
  2405.             CALL ZCHOUT('         (',2)
  2406.             CALL PUTLIN(TEXT,2)
  2407.             CALL ZMESS(')',2)
  2408.         ELSE
  2409.             CALL ZITOF(TEXT,1,MAXL,CIINAM,.FALSE.)
  2410.             CIINUM=FIND(CIINAM,CIILST,NCII)
  2411.             IF (CIINUM.EQ.0) THEN
  2412.                 CALL ERRMES(UNKCII//' - '//CIINAM,-1002)
  2413.                 RETURN
  2414.             ELSE IF (OCCURS(CIINUM)) THEN
  2415.                 CALL ERRMES(CIINAM(:LENSTR(CIINAM))//
  2416.      +                      '= duplicated in control-information list',
  2417.      +                      -1)
  2418.                 STATUS=-1
  2419.                 RETURN
  2420.             ELSE IF (.NOT.CIISTY(SSTYPE(STYPE),CIINUM)) THEN
  2421.                 CALL ERRMES(CIINAM(:LENSTR(CIINAM))//'= n'//
  2422.      +                      'ot allowed here',-1)
  2423.             END IF
  2424.             OCCURS(CIINUM)=.TRUE.
  2425.             NTYPE=ZYNTYP(PTR)
  2426.             IF (NTYPE.EQ.17) THEN
  2427.                 IF (.NOT.CIIAST(CIINUM)) THEN
  2428.                     CALL ERRMES('Invalid asterisk in ci-item '//CIINAM,
  2429.      +                          -1)
  2430.                     STATUS=-1
  2431.                 END IF
  2432.             ELSE IF (CIITYP(CIINUM).EQ.0) THEN
  2433.                 DTYPE=ZYXGDT(PTR)
  2434.                 IF (DTYPE.NE.1 .AND. DTYPE.NE.6) THEN
  2435.                     CALL ERRMES(
  2436.      +'Unit-identifier must be integer/character/*',-1)
  2437.                 ELSE IF (PROCP(PTR)) THEN
  2438.                     CALL ERRMES('Unit-identifier is procedure',-1)
  2439.                 ELSE IF (DTYPE.EQ.6) THEN
  2440.                     INTFIL=.TRUE.
  2441.                     IF (ZYNTYP(PTR).NE.108 .AND.
  2442.      +                  ZYNTYP(PTR).NE.104 .AND.
  2443.      +                  ZYNTYP(PTR).NE.103 .OR.
  2444.      +                  CONSTP(PTR)) THEN
  2445.                         CALL ERRMES(
  2446.      +'Internal file must be variable/array element/substring',-1)
  2447.                         STATUS=-1
  2448.                         RETURN
  2449.                     ELSE IF (STYPE.EQ.65) THEN
  2450. C Get symbol pointer (may have to go down two levels, for a substring
  2451. C of an array element
  2452.                         PTR=ZYDOWN(PTR)
  2453.                         IF (PTR.GT.0) PTR=ZYDOWN(PTR)
  2454.                         IF (PTR.GT.0) PTR=ZYDOWN(PTR)
  2455.                         IF (PTR.GT.0)
  2456.      +                      CALL ERRMES('CIITEM UNITID ERROR',-1001)
  2457. C Say it is modified...
  2458.                         CALL ZYSABT(-PTR,6,32)
  2459. C Also make sure common block (if any) is marked as modified too
  2460.                         CALL UPDCOM(-PTR)
  2461.                     ELSE IF (STYPE.NE.66) THEN
  2462.                         CALL ERRMES(
  2463.      +'Auxiliary i/o statement specifies an internal file',-1)
  2464.                         STATUS=-1
  2465.                         RETURN
  2466.                     END IF
  2467.                 END IF
  2468.             ELSE IF (CIITYP(CIINUM).NE.ZYXGDT(PTR) .OR. BADP(PTR))
  2469.      +      THEN
  2470.                 CALL ERRMES('Incorrect type for '//CIINAM,-1)
  2471.                 STATUS=-1
  2472.             ELSE IF (CIIVAR(CIINUM) .OR. (STYPE.EQ.74 .AND.
  2473.      +               CIINUM.NE.CIIFIL .AND. CIINUM.NE.CIIERR)) THEN
  2474.                 NTYPE=ZYNTYP(PTR)
  2475.                 IF (NTYPE.NE.108 .AND. NTYPE.NE.104) THEN
  2476.                     CALL ERRMES(CIINAM(:LENSTR(CIINAM))//
  2477.      +                          ' requires a var/array elt',-1)
  2478.                     STATUS=-1
  2479.                 ELSE
  2480.                     IF (NTYPE.EQ.104) PTR=ZYDOWN(PTR)
  2481.                     CALL ZYGTSY(-ZYDOWN(PTR),SYMBOL)
  2482.                     IF (NTYPE.EQ.108 .AND.
  2483.      +                  SYMBOL(1).NE.5 .AND.
  2484.      +                  SYMBOL(1).NE.4) THEN
  2485.                         CALL ERRMES(CIINAM(:LENSTR(CIINAM))//
  2486.      +                              ' requires a var/array elt',-1)
  2487.                         STATUS=-1
  2488.                     ELSE
  2489.                         CALL ZYSABT(-ZYDOWN(PTR),6,
  2490.      +                              32)
  2491.                     END IF
  2492.                 END IF
  2493.             END IF
  2494.         END IF
  2495.  
  2496.         END
  2497. C ----------------------------------------------------------------------
  2498. C
  2499. C       E X P R   -   Evaluate an expression in the parse tree
  2500. C
  2501.  
  2502.         SUBROUTINE EXPR(NODE,CONST,CHECK,STATUS)
  2503.         INTEGER NODE,STATUS,CHECK
  2504.         LOGICAL CONST
  2505.  
  2506.         INTEGER PTR,DEPTH,TMP,SFNAME
  2507.         LOGICAL INDATA,INARDC,INSF
  2508.  
  2509.         INTEGER ZYDOWN,ZYNEXT,ZYUP
  2510.         EXTERNAL ZYDOWN,ZYNEXT,ZYUP
  2511.  
  2512. C
  2513. C Setup
  2514. C
  2515.         PTR=NODE
  2516.         INDATA=CHECK.EQ.1
  2517.         INARDC=CHECK.EQ.2
  2518.         INSF=CHECK.GE.1000
  2519.         SFNAME=CHECK/1000
  2520.         DEPTH=0
  2521.         STATUS=-2
  2522. C
  2523. C Process a subtree
  2524. C
  2525.  100    TMP=ZYDOWN(PTR)
  2526.         IF (TMP.GT.0) THEN
  2527.             PTR=TMP
  2528.             DEPTH=DEPTH+1
  2529.             GOTO 100
  2530.         END IF
  2531. C
  2532. C Leaf - process this node now!
  2533. C
  2534.         CALL EVLEAF(PTR,CONST,INDATA,INARDC,INSF,SFNAME,STATUS)
  2535.         IF (STATUS.EQ.-1 .OR. DEPTH.EQ.0) RETURN
  2536. C
  2537. C Process a successor node
  2538. C
  2539.  200    TMP=ZYNEXT(PTR)
  2540.         IF (TMP.GT.0) THEN
  2541.             PTR=TMP
  2542.             GOTO 100
  2543.         END IF
  2544. C
  2545. C Having processed all things below parent node, we now visit the parent
  2546. C (assuming we have one and aren't already at the top)
  2547. C
  2548.         IF (DEPTH.GT.0) THEN
  2549.             DEPTH=DEPTH-1
  2550.             PTR=ZYUP(PTR)
  2551.             CALL EVNODE(PTR,CONST,INDATA,INSF,SFNAME,STATUS)
  2552.             IF (STATUS.EQ.-1) RETURN
  2553.         END IF
  2554.         IF (DEPTH.GT.0) GOTO 200
  2555.  
  2556.         END
  2557. C ----------------------------------------------------------------------
  2558. C
  2559. C       E V L E A F   -   Evaluate a leaf node
  2560. C
  2561.  
  2562.         SUBROUTINE EVLEAF(NODE,CONST,INDATA,INARDC,INSF,SFNAME,STATUS)
  2563.         INTEGER NODE,STATUS,SFNAME
  2564.         LOGICAL CONST,INDATA,INARDC,INSF
  2565.  
  2566.         INTEGER NTYPE,SYMBOL(8),TEXT(1322),SYMPTR,PTR,
  2567.      +          DTYPE,VALUE
  2568.         LOGICAL KONST,VSET
  2569.  
  2570.         INTEGER ZYNTYP,ZYDOWN,ZIAND,LENGTH,ZSCTOI,ZYUP,ZYXGVA,
  2571.      +          ZYXGTB,ZYXGDT,ZYCADT
  2572.         EXTERNAL ZYNTYP,ZYDOWN,ZYGTSY,ZYGTST,ZIAND,LENGTH,ZSCTOI,ZYUP,
  2573.      +           ZYXSDT,ZYXSVA,ZYXSTB,ZYXDST,ZYCADT,
  2574.      +           ZYXDSV,ZYXGVA,ZYXGTB,ZYXGDT
  2575.  
  2576.         NTYPE=ZYNTYP(NODE)
  2577.         SYMPTR=-ZYDOWN(NODE)
  2578.         VSET=.FALSE.
  2579.         KONST=.TRUE.
  2580.         IF (NTYPE.EQ.107) THEN
  2581.             CALL ZYGTST(SYMPTR,TEXT)
  2582.             PTR=1
  2583.             VALUE=ZSCTOI(TEXT,PTR)
  2584.             VSET=.TRUE.
  2585.             DTYPE=1
  2586.         ELSE IF (NTYPE.EQ.106) THEN
  2587.             DTYPE=1
  2588.         ELSE IF (NTYPE.EQ.110) THEN
  2589.             DTYPE=2
  2590.         ELSE IF (NTYPE.EQ.111) THEN
  2591.             DTYPE=5
  2592.         ELSE IF (NTYPE.EQ.109) THEN
  2593.             DTYPE=3
  2594.         ELSE IF (NTYPE.EQ.113) THEN
  2595.             DTYPE=9
  2596.             CALL ZYGTST(SYMPTR,TEXT)
  2597.             CALL ZYXSVA(NODE,LENGTH(TEXT))
  2598.         ELSE IF (NTYPE.EQ.114) THEN
  2599.             DTYPE=6
  2600.             CALL ZYGTST(SYMPTR,TEXT)
  2601.             CALL ZYXSVA(NODE,LENGTH(TEXT))
  2602.         ELSE IF (NTYPE.EQ.116) THEN
  2603.             DTYPE=10
  2604.         ELSE IF (NTYPE.EQ.108) THEN
  2605.             CALL ZYGTSY(SYMPTR,SYMBOL)
  2606. C Set status bit if used in an array declarator
  2607.             IF (INARDC) CALL ZYSABT(SYMPTR,6,1048576)
  2608.             DTYPE=ZYCADT(SYMBOL(4),SYMBOL(5))
  2609.             IF (DTYPE.EQ.0) THEN
  2610.                 CALL ERRMES('Item has an invalid datatype',-1)
  2611.                 RETURN
  2612.             END IF
  2613. C Pretend that subroutine subprograms have no "type", since
  2614. C we can't store negative types in the parse tree nodes.
  2615.             IF (DTYPE.EQ.-1) DTYPE=0
  2616.             IF (SYMBOL(1).EQ.6) THEN
  2617.                 IF (ZIAND(SYMBOL(6),262144).EQ.0) THEN
  2618.                     CALL ERRMES('Parameter used before definition',-1)
  2619.                     STATUS=-1
  2620.                 ELSE IF (SYMBOL(4).EQ.1 .OR.
  2621.      +                   SYMBOL(4).EQ.6) THEN
  2622.                     VSET=.TRUE.
  2623.                     VALUE=SYMBOL(8)
  2624.                 END IF
  2625.             ELSE IF (INDATA) THEN
  2626.                 NTYPE=ZYNTYP(ZYUP(NODE))
  2627.                 IF (NTYPE.NE.104 .AND. NTYPE.NE.103 .OR.
  2628.      +              ZYDOWN(ZYUP(NODE)).NE.NODE) THEN
  2629.                     CALL EVDVAR(SYMPTR,VALUE,STATUS)
  2630.                     VSET=STATUS.EQ.-2
  2631.                 END IF
  2632.             ELSE IF (INARDC .AND.
  2633.      +          ZIAND(SYMBOL(6),4+1024).EQ.0) THEN
  2634.                 CALL ERRMES('Var in adj arr expr must be dummy/common',
  2635.      +                      -1)
  2636.                 STATUS=-1
  2637.             ELSE IF (CONST .AND. .NOT. INARDC) THEN
  2638.                 CALL ERRMES('Non-constant name used in constant expr',
  2639.      +                      -1)
  2640.                 STATUS=-1
  2641.             ELSE IF (INSF .AND. SFNAME.EQ.SYMPTR) THEN
  2642.                 CALL ERRMES('Self-recursive statement function',-1)
  2643.                 STATUS=-1
  2644.             ELSE
  2645.                 IF (SYMBOL(1).EQ.5 .AND.
  2646.      +              SYMBOL(7).NE.0)
  2647.      +              CALL ZYXSTB(NODE,4194304)
  2648.                 IF (SYMBOL(1).EQ.7)
  2649.      +              CALL ZYXSTB(NODE,8388608)
  2650.                 IF (SYMBOL(4).EQ.6) THEN
  2651.                     VSET=.TRUE.
  2652.                     VALUE=SYMBOL(5)
  2653.                     IF (VALUE.EQ.0) THEN
  2654.                         VALUE=1
  2655.                     ELSE IF (VALUE.LT.0) THEN
  2656.                         IF (MOD(ZYXGTB(-VALUE),262144).NE.0)
  2657.      +                      VALUE=ZYXGVA(-VALUE)
  2658.                     END IF
  2659.                 END IF
  2660.                 KONST=.FALSE.
  2661.             END IF
  2662.         ELSE
  2663.             CALL ERRMES('Unrecognised leaf node',-1)
  2664.             CALL ZCHOUT('   (Node type was: ',2)
  2665.             CALL ZPTINT(NTYPE,1,2)
  2666.             CALL ZCHOUT(', node nu'//'mber ',2)
  2667.             CALL ZPTINT(NODE,1,2)
  2668.             CALL ZMESS(')',2)
  2669.             STATUS=-1
  2670.         END IF
  2671.         IF (STATUS.EQ.-2) THEN
  2672.             IF (INDATA) THEN
  2673.                 CALL ZYXDST(NODE,DTYPE)
  2674.                 IF (VSET) CALL ZYXDSV(NODE,VALUE)
  2675.             ELSE
  2676.                 CALL ZYXSDT(NODE,DTYPE)
  2677.                 IF (VSET) CALL ZYXSVA(NODE,VALUE)
  2678.             END IF
  2679.             IF (KONST) CALL ZYXSTB(NODE,2097152)
  2680.         END IF
  2681.  
  2682.         END
  2683. C ----------------------------------------------------------------------
  2684. C
  2685. C       E V N O D E   -   Evaluate a node in an expression
  2686. C
  2687.  
  2688.         SUBROUTINE EVNODE(NODE,CONST,INDATA,INSF,SFNAME,STATUS)
  2689.         INTEGER NODE,STATUS,SFNAME
  2690.         LOGICAL CONST,INDATA,INSF
  2691.  
  2692.         INTEGER NTYPE,DN1TYP,DN2TYP,SYMBOL(8),PTR,ARGN,DN1,
  2693.      +          NTYPE2,DN2
  2694.  
  2695.         LOGICAL ARRAYP,CONSTP
  2696.  
  2697.         INTEGER ZYNTYP,ZYDOWN,ZYNEXT,ZYXGDT,ZYXGTB,ZYUP,ZIAND,
  2698.      +         ZYXGVA
  2699.         EXTERNAL ZYNTYP,ZYDOWN,ZYNEXT,ZYGTSY,ZYXGDT,ZYUP,ZYXGTB,
  2700.      +          ZYXGVA,ZYXDST,ZYXDSV
  2701.  
  2702.         ARRAYP(ARGN)=ZIAND(ZYXGTB(ARGN),4194304).NE.0
  2703.         CONSTP(ARGN)=ZIAND(ZYXGTB(ARGN),2097152).NE.0
  2704.  
  2705.         NTYPE=ZYNTYP(NODE)
  2706.         IF (NTYPE.EQ.119) THEN
  2707.             CALL EVFUNC(NODE,CONST,INSF,STATUS)
  2708.         ELSE IF (NTYPE.EQ.104) THEN
  2709.             IF (CONST .AND. .NOT.INDATA) THEN
  2710.                 CALL ERRMES('Array element invalid in constant expr',
  2711.      +                      -1)
  2712.                 STATUS=-1
  2713.                 RETURN
  2714.             END IF
  2715.             CALL EVAREL(NODE,INDATA,STATUS)
  2716.         ELSE IF (NTYPE.EQ.103) THEN
  2717.             IF (CONST .AND. .NOT.INDATA) THEN
  2718.                 CALL ERRMES('Substring invalid in constant expr',-1)
  2719.                 STATUS=-1
  2720.                 RETURN
  2721.             ELSE IF (INSF) THEN
  2722.                 PTR=NODE
  2723.                 CALL ZYGTSY(SFNAME,SYMBOL)
  2724.  100            IF (ZYNTYP(PTR).NE.119) THEN
  2725.                     PTR=ZYUP(PTR)
  2726.                     IF (PTR.NE.SYMBOL(7)) GOTO 100
  2727.                     CALL ERRMES('Illegal substring in stmt function',
  2728.      +                          -1)
  2729.                     STATUS=-1
  2730.                 END IF
  2731.             END IF
  2732.             CALL EVSBST(NODE,INDATA,STATUS)
  2733.         ELSE IF (NTYPE.EQ.105) THEN
  2734.             CALL EVSSP(NODE,INDATA,STATUS)
  2735.         ELSE IF (NTYPE.EQ.101) THEN
  2736.             CALL ZYXSTB(NODE,ZYXGTB(ZYDOWN(NODE)))
  2737.         ELSE IF (NTYPE.EQ.48) THEN
  2738.             CALL EVDOSP(NODE,STATUS)
  2739.         ELSE IF (NTYPE.EQ.71) THEN
  2740.             CALL ERRMES('EVNODE: INTERNAL ERROR: IOIMDL ENCOUNTERED',
  2741.      +                  -1001)
  2742.         ELSE
  2743.             DN1=ZYDOWN(NODE)
  2744.             IF (ARRAYP(DN1)) THEN
  2745.                 CALL ERRMES('Missing subscript',-1)
  2746.                 STATUS=-1
  2747.                 RETURN
  2748.             END IF
  2749.             DN1TYP=ZYXGDT(DN1)
  2750.             DN2=ZYNEXT(DN1)
  2751.             DN2TYP=0
  2752.             IF (DN2.NE.0) THEN
  2753.                 DN2TYP=ZYXGDT(DN2)
  2754.                 IF (ARRAYP(DN2)) THEN
  2755.                     CALL ERRMES('Missing subscript',-1)
  2756.                     STATUS=-1
  2757.                     RETURN
  2758.                 END IF
  2759.             END IF
  2760.             IF (NTYPE.EQ.91 .OR. NTYPE.EQ.92 .OR. NTYPE.EQ.90 .OR.
  2761.      +          NTYPE.EQ.89 .OR. NTYPE.EQ.94 .OR. NTYPE.EQ.93)
  2762.      +      THEN
  2763.                 CALL EVROP(NODE,DN1TYP,DN2TYP,CONST,STATUS)
  2764.                 IF (CONSTP(DN1).AND.CONSTP(DN2))
  2765.      +              CALL ZYXSTB(NODE,2097152)
  2766.             ELSE IF (NTYPE.EQ.88) THEN
  2767.                 CALL ZYXSDT(NODE,3)
  2768.                 IF (DN1TYP.NE.3 .AND. DN1TYP.NE.12 .AND.
  2769.      +              DN1TYP.NE.13) THEN
  2770.                     CALL ERRMES('..NOT.. applied to non-logical',-1)
  2771.                     STATUS=-1
  2772.                 ELSE IF (CONSTP(NODE)) THEN
  2773.                     CALL ZYXSTB(NODE,2097152)
  2774.                 END IF
  2775.             ELSE IF (NTYPE.EQ.86 .OR. NTYPE.EQ.87 .OR.
  2776.      +               NTYPE.EQ.84 .OR. NTYPE.EQ.85) THEN
  2777.                 CALL EVLOP(NODE,DN1TYP,DN2TYP,CONST,STATUS)
  2778.             ELSE IF (NTYPE.EQ.97 .OR. NTYPE.EQ.46) THEN
  2779.                 IF (DN1TYP.NE.1 .AND. DN1TYP.NE.2
  2780.      +              .AND. DN1TYP.NE.5 .AND.
  2781.      +              DN1TYP.NE.4 .AND. DN1TYP.NE.7
  2782.      +              .AND. DN1TYP.NE.14 .AND.
  2783.      +              DN1TYP.NE.15) THEN
  2784.                     CALL ERRMES('Invalid types for unary 43/45',
  2785.      +                          -1)
  2786.                     STATUS=-1
  2787.                 ELSE
  2788.                     IF (INDATA) THEN
  2789.                         CALL ZYXDST(NODE,DN1TYP)
  2790.                     ELSE
  2791.                         CALL ZYXSDT(NODE,DN1TYP)
  2792.                     END IF
  2793.                     IF (CONSTP(DN1)) THEN
  2794.                         CALL ZYXSTB(NODE,2097152)
  2795.                         IF (NTYPE.EQ.97 .AND. DN1TYP.EQ.1)
  2796.      +                  THEN
  2797.                             IF (INDATA) THEN
  2798.                                 CALL ZYXDSV(NODE,ZYXGVA(DN1))
  2799.                             ELSE
  2800.                                 CALL ZYXSVA(NODE,ZYXGVA(DN1))
  2801.                             END IF
  2802.                         ELSE IF (DN1TYP.EQ.1) THEN
  2803.                             IF (INDATA) THEN
  2804.                                 CALL ZYXDSV(NODE,-ZYXGVA(DN1))
  2805.                             ELSE
  2806.                                 CALL ZYXSVA(NODE,-ZYXGVA(DN1))
  2807.                             END IF
  2808.                         END IF
  2809.                     END IF
  2810.                 END IF
  2811.             ELSE IF (NTYPE.EQ.95 .OR. NTYPE.EQ.96 .OR.
  2812.      +          NTYPE.EQ.98 .OR. NTYPE.EQ.99 .OR.
  2813.      +          NTYPE.EQ.100) THEN
  2814.                 CALL EVA2OP(NODE,DN1,DN2,DN1TYP,DN2TYP,CONST,INDATA,
  2815.      +                      STATUS)
  2816.             ELSE IF (NTYPE.EQ.70) THEN
  2817.                 IF (DN1TYP.NE.6 .OR. DN2TYP.GT.6) THEN
  2818.                     CALL ERRMES('Concatenation of non-characters',-1)
  2819.                     STATUS=-1
  2820.                 ELSE
  2821.                     CALL ZYXSDT(NODE,6)
  2822.                     IF (ZYXGVA(DN1).EQ.0 .AND. .NOT.CONSTP(DN1) .OR.
  2823.      +                  ZYXGVA(DN2).EQ.0 .AND. .NOT.CONSTP(DN2))
  2824.      +                  CALL ERRMES('Concatenation of assumed '//
  2825.      +                              'length character string',-1002)
  2826.                     IF (ZYXGVA(DN1).LE.0 .AND. ZYXGVA(DN2).LE.0)
  2827.      +              THEN
  2828.                         CALL ZYXSVA(NODE,-1)
  2829.                     ELSE
  2830.                         CALL ZYXSVA(NODE,
  2831.      +                                  ZYXGVA(DN1)+ZYXGVA(DN2))
  2832.                     END IF
  2833.                 END IF
  2834.             ELSE IF (NTYPE.EQ.102) THEN
  2835.                 NTYPE=ZYNTYP(DN1)
  2836.                 IF (NTYPE.EQ.46 .OR. NTYPE.EQ.97)
  2837.      +              NTYPE=ZYNTYP(ZYDOWN(DN1))
  2838.                 NTYPE2=ZYNTYP(DN2)
  2839.                 IF (NTYPE2.EQ.46 .OR. NTYPE2.EQ.97)
  2840.      +              NTYPE2=ZYNTYP(ZYDOWN(DN2))
  2841.                 IF (NTYPE.NE.107 .AND. NTYPE.NE.110 .AND.
  2842.      +              NTYPE.NE.111 .OR. NTYPE2.NE.107 .AND.
  2843.      +              NTYPE2.NE.110 .AND. NTYPE2.NE.111) THEN
  2844.                     CALL ERRMES('Invalid complex constant',-1)
  2845.                 ELSE IF (DN1TYP.EQ.5 .OR.
  2846.      +               DN2TYP.EQ.5) THEN
  2847.                     IF (INDATA) THEN
  2848.                         CALL ZYXDST(NODE,7)
  2849.                     ELSE
  2850.                         CALL ZYXSDT(NODE,7)
  2851.                     END IF
  2852.                 ELSE
  2853.                     IF (INDATA) THEN
  2854.                         CALL ZYXDST(NODE,4)
  2855.                     ELSE
  2856.                         CALL ZYXSDT(NODE,4)
  2857.                     END IF
  2858.                 END IF
  2859.             ELSE
  2860.                 CALL ERRMES('Unknown operator node',-1)
  2861.                 STATUS=-1
  2862.             END IF
  2863.         END IF
  2864.  
  2865.         END
  2866. C ----------------------------------------------------------------------
  2867. C
  2868. C       E V F U N C   -   Evaluate a function call
  2869. C
  2870.  
  2871.         SUBROUTINE EVFUNC(NODE,CONST,INSF,STATUS)
  2872.         INTEGER NODE,STATUS
  2873.         LOGICAL CONST,INSF
  2874.  
  2875.         INTEGER SYMBOL(8),SYMPTR,PTR,DTYPE
  2876.  
  2877.         INTEGER ZYDOWN,ZIAND,ZYXGVA,ZYXGDT
  2878.         EXTERNAL ZYDOWN,ZIAND,ZYGTSY,ZYXSDT,ZYXGDT
  2879.  
  2880.         PTR=ZYDOWN(NODE)
  2881.         DTYPE=ZYXGDT(PTR)
  2882.  
  2883.         IF (DTYPE.EQ.6) THEN
  2884.             CALL ZYXSVA(NODE,ZYXGVA(PTR))
  2885.         END IF
  2886.  
  2887.         IF (CONST) THEN
  2888.             CALL ERRMES('Function reference in constant expr',-1)
  2889.             STATUS=-1
  2890.         ELSE
  2891.             CALL ZYGTSY(-ZYDOWN(ZYDOWN(NODE)),SYMBOL)
  2892.             IF (SYMBOL(4).EQ.8) THEN
  2893.                 CALL EVFGEN(NODE,SYMBOL,STATUS)
  2894.             ELSE
  2895.                 CALL ZYXSDT(NODE,SYMBOL(4))
  2896.                 IF (SYMBOL(1).EQ.8) THEN
  2897.                     CALL EVSF(NODE,SYMBOL,STATUS)
  2898.                 ELSE IF (ZIAND(SYMBOL(6),
  2899.      +                         4096+2).NE.0) THEN
  2900.                     CALL EVFINT(NODE,SYMBOL,STATUS)
  2901.                 ELSE
  2902.                     CALL EVFEXT(NODE,SYMBOL,INSF,STATUS)
  2903.                 END IF
  2904.             END IF
  2905.         END IF
  2906.  
  2907.         END
  2908. C ----------------------------------------------------------------------
  2909. C
  2910. C       E V R O P   -   Evaluate a relational operator
  2911. C
  2912.  
  2913.         SUBROUTINE EVROP(NODE,DN1TYP,DN2TYP,CONST,STATUS)
  2914.         INTEGER NODE,DN1TYP,DN2TYP,STATUS
  2915.         LOGICAL CONST
  2916.  
  2917.         CALL ZYXSDT(NODE,3)
  2918.         IF (DN1TYP.NE.1 .AND. DN1TYP.NE.2 .AND.
  2919.      +      DN1TYP.NE.5 .AND. DN1TYP.NE.4 .AND.
  2920.      +      DN1TYP.NE.6 .AND. DN1TYP.NE.14 .AND.
  2921.      +      DN1TYP.NE.15 .AND. DN1TYP.NE.7 .OR.
  2922.      +      DN2TYP.NE.1 .AND. DN2TYP.NE.4 .AND.
  2923.      +      DN2TYP.NE.5 .AND. DN2TYP.NE.2 .AND.
  2924.      +      DN2TYP.NE.6 .AND. DN2TYP.NE.14 .AND.
  2925.      +      DN2TYP.NE.15 .AND. DN2TYP.NE.7) THEN
  2926.             CALL ERRMES('Invalid types in relational',-1)
  2927.             STATUS=-1
  2928.         ELSE IF (DN1TYP.EQ.6 .NEQV. DN2TYP.EQ.6) THEN
  2929.             CALL ERRMES('Incompatible types in relational',-1)
  2930.             STATUS=-1
  2931.         ELSE IF ((DN1TYP.EQ.15 .OR. DN2TYP.EQ.15) .AND.
  2932.      +           (DN1TYP.EQ.4 .OR. DN1TYP.EQ.7 .OR.
  2933.      +           DN2TYP.EQ.4 .OR. DN2TYP.EQ.7))
  2934.      +  THEN
  2935.             CALL ERRMES('Complex a'//'nd quadruple precision mixed',
  2936.      +                  -1)
  2937.             STATUS=-1
  2938.         END IF
  2939.  
  2940.         END
  2941. C ----------------------------------------------------------------------
  2942. C
  2943. C       E V A 2 O P   -   Evaluate arithmetic binary operator
  2944. C
  2945.  
  2946.         SUBROUTINE EVA2OP(NODE,DN1,DN2,DN1TYP,DN2TYP,CONST,INDATA,
  2947.      +                    STATUS)
  2948.         INTEGER NODE,DN1,DN2,DN1TYP,DN2TYP,STATUS
  2949.         LOGICAL CONST,INDATA
  2950.  
  2951.         INTEGER ARITH(-3:15,-3:15),ARGN,
  2952.      +          NTYPE
  2953.         LOGICAL EVALIT
  2954.  
  2955.         SAVE ARITH
  2956.  
  2957.         LOGICAL CONSTP
  2958.  
  2959.         INTEGER ZYXGVA,ZYXGTB,ZIAND,ZYNTYP
  2960.         EXTERNAL ZYXSDT,ZYXSVA,ZYXGVA,ZYXGTB,ZIAND,
  2961.      +           ZYNTYP,ZYXDST,ZYXDSV
  2962.  
  2963.         DATA ARITH(1,1)/1/,
  2964.      +       ARITH(1,2)/2/,
  2965.      +       ARITH(1,5)/5/,
  2966.      +       ARITH(1,4)/4/,
  2967.      +       ARITH(1,7)/7/,
  2968.      +       ARITH(1,14)/14/,
  2969.      +       ARITH(1,15)/15/,
  2970.      +       ARITH(2,1)/2/,
  2971.      +       ARITH(2,2)/2/,
  2972.      +       ARITH(2,5)/5/,
  2973.      +       ARITH(2,4)/4/,
  2974.      +       ARITH(2,7)/7/,
  2975.      +       ARITH(2,14)/2/,
  2976.      +       ARITH(2,15)/15/,
  2977.      +       ARITH(5,1)/5/,
  2978.      +       ARITH(5,2)/5/,
  2979.      +       ARITH(5,5)/5/,
  2980.      +       ARITH(5,4)/7/,
  2981.      +       ARITH(5,7)/7/,
  2982.      +       ARITH(5,14)/5/
  2983.         DATA ARITH(5,15)/15/,
  2984.      +       ARITH(4,1)/4/,
  2985.      +       ARITH(4,2)/4/,
  2986.      +       ARITH(4,5)/7/,
  2987.      +       ARITH(4,4)/4/,
  2988.      +       ARITH(4,7)/7/,
  2989.      +       ARITH(4,14)/14/,
  2990.      +       ARITH(4,15)/0/,
  2991.      +       ARITH(7,1)/7/,
  2992.      +       ARITH(7,2)/7/,
  2993.      +       ARITH(7,5)/7/,
  2994.      +       ARITH(7,4)/7/,
  2995.      +       ARITH(7,7)/7/,
  2996.      +       ARITH(7,14)/7/,
  2997.      +       ARITH(7,15)/0/,
  2998.      +       ARITH(14,1)/1/,
  2999.      +       ARITH(14,2)/2/,
  3000.      +       ARITH(14,5)/5/,
  3001.      +       ARITH(14,4)/4/,
  3002.      +       ARITH(14,7)/7/
  3003.         DATA ARITH(14,14)/14/,
  3004.      +       ARITH(14,15)/15/,
  3005.      +       ARITH(15,1)/15/,
  3006.      +       ARITH(15,2)/15/,
  3007.      +       ARITH(15,5)/15/,
  3008.      +       ARITH(15,4)/0/,
  3009.      +       ARITH(15,7)/0/,
  3010.      +       ARITH(15,14)/15/,
  3011.      +       ARITH(15,15)/15/
  3012.  
  3013.         CONSTP(ARGN)=ZIAND(ZYXGTB(ARGN),2097152).NE.0
  3014.  
  3015.         IF (DN1TYP.NE.1 .AND. DN1TYP.NE.2 .AND.
  3016.      +      DN1TYP.NE.5 .AND. DN1TYP.NE.4 .AND.
  3017.      +      DN1TYP.NE.7 .AND. DN1TYP.NE.14 .AND.
  3018.      +      DN1TYP.NE.15 .OR.
  3019.      +      DN2TYP.NE.1 .AND. DN2TYP.NE.4 .AND.
  3020.      +      DN2TYP.NE.2 .AND. DN2TYP.NE.5 .AND.
  3021.      +      DN2TYP.NE.7 .AND. DN2TYP.NE.14 .AND.
  3022.      +      DN2TYP.NE.15) THEN
  3023.             CALL ERRMES('Invalid types for arithmetic op',-1)
  3024.             STATUS=-1
  3025.         ELSE IF (ARITH(DN1TYP,DN2TYP).EQ.0) THEN
  3026.             CALL ERRMES('Complex a'//'nd quadruple precision mixed',
  3027.      +                  -1)
  3028.             STATUS=-1
  3029.         ELSE
  3030.             IF (INDATA) THEN
  3031.                 CALL ZYXDST(NODE,ARITH(DN1TYP,DN2TYP))
  3032.             ELSE
  3033.                 CALL ZYXSDT(NODE,ARITH(DN1TYP,DN2TYP))
  3034.             END IF
  3035.             IF (CONSTP(DN1).AND.CONSTP(DN2)) THEN
  3036.                 CALL ZYXSTB(NODE,2097152)
  3037.                 NTYPE=ZYNTYP(NODE)
  3038.                 EVALIT=DN1TYP.EQ.1 .AND. DN2TYP.EQ.1
  3039.                 IF (EVALIT .AND. .NOT.INDATA) THEN
  3040.                   IF (NTYPE.EQ.95) THEN
  3041.                       CALL ZYXSVA(NODE,ZYXGVA(DN1)+ZYXGVA(DN2))
  3042.                   ELSE IF (NTYPE.EQ.96) THEN
  3043.                       CALL ZYXSVA(NODE,ZYXGVA(DN1)-ZYXGVA(DN2))
  3044.                   ELSE IF (NTYPE.EQ.98) THEN
  3045.                       CALL ZYXSVA(NODE,ZYXGVA(DN1)*ZYXGVA(DN2))
  3046.                   ELSE IF (NTYPE.EQ.99) THEN
  3047.                       CALL ZYXSVA(NODE,ZYXGVA(DN1)/ZYXGVA(DN2))
  3048.                   ELSE IF (NTYPE.EQ.100) THEN
  3049.                       CALL ZYXSVA(NODE,ZYXGVA(DN1)**ZYXGVA(DN2))
  3050.                   END IF
  3051.                 ELSE IF (EVALIT) THEN
  3052.                   IF (NTYPE.EQ.95) THEN
  3053.                       CALL ZYXDSV(NODE,ZYXGVA(DN1)+ZYXGVA(DN2))
  3054.                   ELSE IF (NTYPE.EQ.96) THEN
  3055.                       CALL ZYXDSV(NODE,ZYXGVA(DN1)-ZYXGVA(DN2))
  3056.                   ELSE IF (NTYPE.EQ.98) THEN
  3057.                       CALL ZYXDSV(NODE,ZYXGVA(DN1)*ZYXGVA(DN2))
  3058.                   ELSE IF (NTYPE.EQ.99) THEN
  3059.                       CALL ZYXDSV(NODE,ZYXGVA(DN1)/ZYXGVA(DN2))
  3060.                   ELSE IF (NTYPE.EQ.100) THEN
  3061.                       CALL ZYXDSV(NODE,ZYXGVA(DN1)**ZYXGVA(DN2))
  3062.                   END IF
  3063.                 END IF
  3064.             END IF
  3065.         END IF
  3066.  
  3067.         END
  3068. C ----------------------------------------------------------------------
  3069. C
  3070. C       E V L O P   -   Evaluate a logical operator
  3071. C
  3072.  
  3073.         SUBROUTINE EVLOP(NODE,DN1TYP,DN2TYP,CONST,STATUS)
  3074.         INTEGER NODE,DN1TYP,DN2TYP,STATUS
  3075.         LOGICAL CONST
  3076.  
  3077.         INTEGER RESULT(3,3),T1,T2
  3078.  
  3079.         SAVE RESULT
  3080.  
  3081.         EXTERNAL ZYXSDT
  3082.  
  3083.         DATA RESULT/12,13,3,
  3084.      +              13,13,3,
  3085.      +              3,3,3/
  3086.  
  3087.         IF (DN1TYP.EQ.12) THEN
  3088.             T1=1
  3089.         ELSE IF (DN1TYP.EQ.13) THEN
  3090.             T1=2
  3091.         ELSE IF (DN1TYP.EQ.3) THEN
  3092.             T1=3
  3093.         ELSE
  3094.             CALL ERRMES(
  3095.      +'Invalid type of first operand for logical operator',-1)
  3096.             STATUS=-1
  3097.             RETURN
  3098.         END IF
  3099.         IF (DN2TYP.EQ.12) THEN
  3100.             T2=1
  3101.         ELSE IF (DN2TYP.EQ.13) THEN
  3102.             T2=2
  3103.         ELSE IF (DN2TYP.EQ.3) THEN
  3104.             T2=3
  3105.         ELSE
  3106.             CALL ERRMES(
  3107.      +'Invalid type of second operand for logical operator',-1)
  3108.             STATUS=-1
  3109.             RETURN
  3110.         END IF
  3111.         CALL ZYXSDT(NODE,RESULT(T1,T2))
  3112.  
  3113.         END
  3114. C ----------------------------------------------------------------------
  3115. C
  3116. C       E V A R E L   -   Evaluate an array element reference
  3117. C
  3118.  
  3119.         SUBROUTINE EVAREL(NODE,INDATA,STATUS)
  3120.         INTEGER NODE,STATUS
  3121.         LOGICAL INDATA
  3122.  
  3123.         INTEGER PTR,SYMBOL(8),SYMPTR,NSUBS,N,LIMITS(2,10),TMP,
  3124.      +          ARGN,DTYPE
  3125.         LOGICAL ADJP,INFP
  3126.  
  3127.         LOGICAL CONSTP
  3128.  
  3129.         LOGICAL ZYXGAD
  3130.         INTEGER ZYDOWN,ZYNEXT,ZYXGTB,ZYXGDT,ZIAND,ZYXGVA,
  3131.      +          ZYNTYP
  3132.         EXTERNAL ZYDOWN,ZYNEXT,ZYGTSY,ZYXGTB,ZYXGDT,
  3133.      +           ZYXGAD,ZIAND,ZYXGVA,ZYXSDT,
  3134.      +           ZYXSVA,ZYXDST,ZYXDSV,ZYNTYP
  3135.  
  3136.         CONSTP(ARGN)=ZIAND(ZYXGTB(ARGN),2097152).NE.0
  3137.  
  3138.         PTR=ZYDOWN(NODE)
  3139.         SYMPTR=-ZYDOWN(PTR)
  3140.         DTYPE=ZYXGDT(PTR)
  3141.         IF (INDATA) THEN
  3142.             CALL ZYXDST(NODE,DTYPE)
  3143.         ELSE
  3144.             CALL ZYXSDT(NODE,DTYPE)
  3145.         END IF
  3146.         IF (.NOT.ZYXGAD(SYMPTR,NSUBS,LIMITS,ADJP,INFP)) THEN
  3147.             CALL ERRMES('Array elt before array declarator',-1)
  3148.             STATUS=-1
  3149.             RETURN
  3150.         END IF
  3151.         PTR=ZYNEXT(PTR)
  3152.         N=0
  3153.  200    N=N+1
  3154.         TMP=ZYXGDT(PTR)
  3155.         IF (TMP.NE.1 .AND. TMP.NE.2 .AND.
  3156.      +      TMP.NE.5 .AND. TMP.NE.14 .AND.
  3157.      +      TMP.NE.15) THEN
  3158.             CALL ERRMES('Invalid datatype of subscript expression',-1)
  3159.             STATUS=-1
  3160.             RETURN
  3161.         ELSE IF (CONSTP(PTR) .AND. .NOT.ADJP
  3162.      +            .AND. .NOT.INFP .AND. TMP.EQ.1 .AND.
  3163.      +           LIMITS(1,N).LE.LIMITS(2,N)) THEN
  3164.             TMP=ZYXGVA(PTR)
  3165.             IF (TMP.LT.LIMITS(1,N).OR.TMP.GT.LIMITS(2,N)) THEN
  3166.                 CALL ERRMES('Subscript out of range',-1)
  3167.                 STATUS=-1
  3168.                 RETURN
  3169.             END IF
  3170.         END IF
  3171.         PTR=ZYNEXT(PTR)
  3172.         IF (PTR.GT.0 .AND. N.LT.NSUBS) GOTO 200
  3173.         IF (PTR.GT.0) THEN
  3174.             CALL ERRMES('Too many subscripts',-1)
  3175.             STATUS=-1
  3176.         ELSE IF (N.LT.NSUBS) THEN
  3177.             CALL ERRMES('Insufficient subscripts',-1)
  3178.             STATUS=-1
  3179.         ELSE
  3180.             CALL ZYGTSY(SYMPTR,SYMBOL)
  3181.             IF (SYMBOL(4).EQ.6) THEN
  3182.                 IF (SYMBOL(5).EQ.0) THEN
  3183.                     TMP=1
  3184.                 ELSE IF (SYMBOL(5).GT.0) THEN
  3185.                     TMP=SYMBOL(5)
  3186.                 ELSE IF (CONSTP(-SYMBOL(5))) THEN
  3187.                     TMP=ZYXGVA(-SYMBOL(5))
  3188.                 ELSE IF (ZYNTYP(-SYMBOL(5)).EQ.17)
  3189.      +          THEN
  3190.                     TMP=0
  3191.                 ELSE
  3192.                     RETURN
  3193.                 END IF
  3194.                 IF (INDATA) THEN
  3195.                     CALL ZYXDSV(NODE,TMP)
  3196.                     ELSE
  3197.                     CALL ZYXSVA(NODE,TMP)
  3198.                 END IF
  3199.             END IF
  3200.         END IF
  3201.  
  3202.         END
  3203. C ----------------------------------------------------------------------
  3204. C
  3205. C       E V S S P   -   Evaluate substring specifier
  3206. C
  3207.  
  3208.         SUBROUTINE EVSSP(NODE,INDATA,STATUS)
  3209.         INTEGER NODE,STATUS
  3210.         LOGICAL INDATA
  3211.  
  3212.         INTEGER PTR
  3213.  
  3214.         INTEGER ZYDOWN,ZYNEXT,ZYXGDT
  3215.         EXTERNAL ZYDOWN,ZYNEXT,ZYXGDT,ZYXSDT
  3216.  
  3217.         IF (INDATA) THEN
  3218.             CALL ZYXDST(NODE,11)
  3219.         ELSE
  3220.             CALL ZYXSDT(NODE,11)
  3221.         END IF
  3222.         PTR=ZYDOWN(NODE)
  3223.         IF (ZYXGDT(PTR).NE.1) THEN
  3224.             CALL ERRMES('Invalid substring specifier (1)',-1)
  3225.             STATUS=-1
  3226.         ELSE IF (ZYXGDT(ZYNEXT(PTR)).NE.1) THEN
  3227.             CALL ERRMES('Invalid substring specifier (2)',-1)
  3228.             STATUS=-1
  3229.         END IF
  3230.  
  3231.         END
  3232. C ----------------------------------------------------------------------
  3233. C
  3234. C       E V S B S T   -   Evaluate substring reference
  3235. C
  3236.  
  3237.         SUBROUTINE EVSBST(NODE,INDATA,STATUS)
  3238.         INTEGER NODE,STATUS
  3239.         LOGICAL INDATA
  3240.  
  3241.         INTEGER PTR,VALUE,VAL1,VAL2,SYMBOL(8),TMPPTR,ARGN
  3242.  
  3243.         INTEGER ZYDOWN,ZYNEXT,ZYXGDT,ZYXGVA,ZIAND,ZYXGTB,
  3244.      +          ZYNTYP
  3245.         EXTERNAL ZYDOWN,ZYNEXT,ZYXGDT,ZYXSDT,ZYXSVA,ZYNTYP,
  3246.      +           ZYXDST,ZYXDSV,ZYXGVA,ZIAND,ZYXGTB
  3247.  
  3248.         LOGICAL CONSTP,ARRAYP
  3249.  
  3250.         CONSTP(ARGN)=ZIAND(ZYXGTB(ARGN),2097152).NE.0
  3251.         ARRAYP(ARGN)=ZIAND(ZYXGTB(ARGN),4194304).NE.0
  3252.  
  3253.         PTR=ZYDOWN(NODE)
  3254.         IF (ZYXGDT(PTR).NE.6) THEN
  3255.             CALL ERRMES('Substring n'//'ot of a character item',
  3256.      +                  -1)
  3257.             STATUS=-1
  3258.             RETURN
  3259.         ELSE IF (ZYXGDT(ZYNEXT(PTR)).NE.11) THEN
  3260.             CALL ERRMES('Internal Error: Didn''t expect invalid substr',
  3261.      +                  -1001)
  3262.         ELSE IF (ARRAYP(PTR)) THEN
  3263.             CALL ERRMES(
  3264.      +'Missing subscript on array name in substring reference',
  3265.      +                      -1)
  3266.                 RETURN
  3267.         ELSE
  3268. C Try to work out how long the substring is, and say zero if unknown
  3269.             VALUE=0
  3270. C First see if we know how long it might be
  3271.             TMPPTR=ZYDOWN(PTR)
  3272. C .. down an extra level further for substrings of array elements
  3273.             IF (TMPPTR.GT.0) TMPPTR=ZYDOWN(TMPPTR)
  3274.             CALL ZYGTSY(-TMPPTR,SYMBOL)
  3275.             IF (SYMBOL(5).LT.0) THEN
  3276.                 IF (CONSTP(-SYMBOL(5)))
  3277.      +              SYMBOL(5)=ZYXGVA(-SYMBOL(5))
  3278.             ELSE IF (SYMBOL(5).EQ.0) THEN
  3279.                 SYMBOL(5)=1
  3280.             END IF
  3281.             IF (SYMBOL(5).GT.0) THEN
  3282. C We know how long the whole character variable is - now try for the
  3283. C substring specifier
  3284.                 PTR=ZYDOWN(ZYNEXT(PTR))
  3285.                 IF (CONSTP(PTR)) THEN
  3286.                     IF (ZYNTYP(PTR).EQ.106) THEN
  3287.                         VAL1=1
  3288.                     ELSE
  3289.                         VAL1=ZYXGVA(PTR)
  3290.                     END IF
  3291.                     PTR=ZYNEXT(PTR)
  3292.                     IF (CONSTP(PTR)) THEN
  3293.                         IF (ZYNTYP(PTR).EQ.106) THEN
  3294.                             VAL2=SYMBOL(5)
  3295.                         ELSE
  3296.                             VAL2=ZYXGVA(PTR)
  3297.                         END IF
  3298.                         VALUE=VAL2-VAL1+1
  3299.                         IF (VALUE.LT.1 .OR. VAL1.LT.1 .OR.
  3300.      +                      VAL2.LT.1 .OR.
  3301.      +                      VAL1.GT.SYMBOL(5) .OR.
  3302.      +                      VAL2.GT.SYMBOL(5)) THEN
  3303.                             STATUS=-1
  3304.                             CALL ERRMES(
  3305.      +                           'Illegal substring specifier value',
  3306.      +                           -1)
  3307.                             RETURN
  3308.                         END IF
  3309.                     END IF
  3310.                 END IF
  3311.             END IF
  3312.         END IF
  3313.         IF (INDATA) THEN
  3314.             CALL ZYXDST(NODE,6)
  3315.             CALL ZYXDSV(NODE,VALUE)
  3316.         ELSE
  3317.             CALL ZYXSDT(NODE,6)
  3318.             CALL ZYXSVA(NODE,VALUE)
  3319.         END IF
  3320.  
  3321.         END
  3322. C ----------------------------------------------------------------------
  3323. C
  3324. C       E V D O S P   -   Evaluate an implied do spec
  3325. C
  3326.  
  3327.         SUBROUTINE EVDOSP(NODE,STATUS)
  3328.         INTEGER NODE,STATUS
  3329.  
  3330.         INTEGER PTR,DTYPE
  3331.  
  3332.         INTEGER ZYDOWN,ZYNEXT,ZYXGTB,ZIAND,ZYXGDT
  3333.         EXTERNAL ZYDOWN,ZYNEXT,ZYXGTB,ZIAND,ZYXGDT
  3334.  
  3335.         PTR=ZYDOWN(NODE)
  3336.         DTYPE=ZYXGDT(PTR)
  3337.         IF (ZIAND(ZYXGTB(PTR),4194304).NE.0) THEN
  3338.             CALL ERRMES('Invalid implied DO loop variable',-1)
  3339.             STATUS=-1
  3340.         ELSE IF (DTYPE.NE.1 .AND. DTYPE.NE.2 .AND.
  3341.      +           DTYPE.NE.5 .AND. DTYPE.NE.15 .AND.
  3342.      +           DTYPE.NE.14) THEN
  3343.             CALL ERRMES('Invalid type of implied DO loop variable',-1)
  3344.             STATUS=-1
  3345.         ELSE
  3346.             PTR=ZYNEXT(PTR)
  3347.  100        DTYPE=ZYXGDT(PTR)
  3348.             IF (ZIAND(ZYXGTB(PTR),4194304).NE.0) THEN
  3349.                 CALL ERRMES('Missing subscript in implied DO expr',-1)
  3350.                 STATUS=-1
  3351.                 RETURN
  3352.             ELSE IF (DTYPE.NE.1 .AND. DTYPE.NE.2 .AND.
  3353.      +               DTYPE.NE.5 .AND. DTYPE.NE.15 .AND.
  3354.      +               DTYPE.NE.14) THEN
  3355.                 CALL ERRMES('Invalid type of implied DO loop expr',-1)
  3356.                 STATUS=-1
  3357.                 RETURN
  3358.             END IF
  3359.             PTR=ZYNEXT(PTR)
  3360.             IF (PTR.NE.0) GOTO 100
  3361.         END IF
  3362.  
  3363.         END
  3364. C ----------------------------------------------------------------------
  3365. C
  3366. C       E V F I N T   -   Evaluate function: INTRINSIC (and not generic)
  3367. C
  3368.  
  3369.         SUBROUTINE EVFINT(NODE,SYMBOL,STATUS)
  3370.         INTEGER NODE,SYMBOL(8),STATUS
  3371.  
  3372.         LOGICAL T,F
  3373.         PARAMETER (T=.TRUE.,F=.FALSE.)
  3374.  
  3375.         INTEGER NINTS
  3376.         PARAMETER (NINTS=67)
  3377.  
  3378.         CHARACTER*6 INTNAM(NINTS),NAME
  3379.         LOGICAL VALID(8,NINTS)
  3380.         INTEGER NARGS(NINTS),TYPE(-3:15),J,J2,NAARGS,PTR,
  3381.      +          TEXT(134),FUN,ATYPE
  3382.  
  3383.         SAVE
  3384.  
  3385.         INTEGER FIND,LENSTR
  3386.  
  3387.         INTEGER ZYDOWN,ZYNEXT,ZYXGDT,LENGTH,ZYXGTB,ZIAND
  3388.         EXTERNAL ZYDOWN,ZYNEXT,ZYXGDT,LENGTH,ZITOF,ZYGTST,
  3389.      +           ZYXGTB,ZIAND,ZYXSVA
  3390.  
  3391.         DATA TYPE(1)/1/,
  3392.      +       TYPE(2)/2/,
  3393.      +       TYPE(5)/3/,
  3394.      +       TYPE(4)/4/,
  3395.      +       TYPE(6)/5/,
  3396.      +       TYPE(7)/6/,
  3397.      +       TYPE(14)/7/,
  3398.      +       TYPE(15)/8/,
  3399.      +       TYPE(3),TYPE(-2),TYPE(-1),
  3400.      +       TYPE(10),TYPE(-3),TYPE(9),
  3401.      +       TYPE(11),TYPE(12),TYPE(13)/9*0/
  3402.  
  3403. C Table:   Name  Nargs  Legal argtypes
  3404. C ------                INT REAL DP COMPL CHAR DCMPLX INT*2 REAL*16
  3405.  
  3406.         DATA (INTNAM(J),NARGS(J),(VALID(J2,J),J2=1,8),J=1,19)/
  3407.      +'AIMAG',1,F,F,F,T,F,F,F,F,
  3408.      +'ALOG',1,F,T,F,F,F,F,F,F,
  3409.      +'ALOG10',1,F,T,F,F,F,F,F,F,
  3410.      +'AMAX0',-2,T,F,F,F,F,F,F,F,
  3411.      +'AMAX1',-2,F,T,F,F,F,F,F,F,
  3412.      +'AMIN0',-2,T,F,F,F,F,F,F,F,
  3413.      +'AMIN1',-2,F,T,F,F,F,F,F,F,
  3414.      +'AMOD',2,F,T,F,F,F,F,F,F,
  3415.      +'CABS',1,F,F,F,T,F,F,F,F,
  3416.      +'CCOS',1,F,F,F,T,F,F,F,F,
  3417.      +'CDABS',1,F,F,F,F,F,T,F,F,
  3418.      +'CEXP',1,F,F,F,T,F,F,F,F,
  3419.      +'CHAR',1,T,F,F,F,F,F,F,F,
  3420.      +'CLOG',1,F,F,F,T,F,F,F,F,
  3421.      +'CMPLX',-1,T,T,T,T,F,T,T,T,
  3422.      +'CONJG',1,F,F,F,T,F,F,F,F,
  3423.      +'CSIN',1,F,F,F,T,F,F,F,F,
  3424.      +'CSQRT',1,F,F,F,T,F,F,F,F,
  3425.      +'DABS',1,F,F,T,F,F,F,F,F/
  3426.         DATA (INTNAM(J),NARGS(J),(VALID(J2,J),J2=1,8),J=20,38)/
  3427.      +'DACOS',1,F,F,T,F,F,F,F,F,
  3428.      +'DASIN',1,F,F,T,F,F,F,F,F,
  3429.      +'DATAN',1,F,F,T,F,F,F,F,F,
  3430.      +'DATAN2',2,F,F,T,F,F,F,F,F,
  3431.      +'DBLE',1,T,T,T,T,F,T,T,T,
  3432.      +'DCMPLX',-1,T,T,T,T,F,T,T,T,
  3433.      +'DCONJG',1,F,F,F,F,F,T,F,F,
  3434.      +'DCOS',1,F,F,T,F,F,F,F,F,
  3435.      +'DCOSH',1,F,F,T,F,F,F,F,F,
  3436.      +'DDIM',2,F,F,T,F,F,F,F,F,
  3437.      +'DEXP',1,F,F,T,F,F,F,F,F,
  3438.      +'DIMAG',1,F,F,F,F,F,T,F,F,
  3439.      +'DINT',1,F,F,T,F,F,F,F,F,
  3440.      +'DLOG',1,F,F,T,F,F,F,F,F,
  3441.      +'DLOG10',1,F,F,T,F,F,F,F,F,
  3442.      +'DMAX1',-2,F,F,T,F,F,F,F,F,
  3443.      +'DMIN1',-2,F,F,T,F,F,F,F,F,
  3444.      +'DMOD',2,F,F,T,F,F,F,F,F,
  3445.      +'DNINT',1,F,F,T,F,F,F,F,F/
  3446.         DATA (INTNAM(J),NARGS(J),(VALID(J2,J),J2=1,8),J=39,57)/
  3447.      +'DPROD',2,F,T,F,F,F,F,F,F,
  3448.      +'DSIGN',2,F,F,T,F,F,F,F,F,
  3449.      +'DSIN',1,F,F,T,F,F,F,F,F,
  3450.      +'DSINH',1,F,F,T,F,F,F,F,F,
  3451.      +'DSQRT',1,F,F,T,F,F,F,F,F,
  3452.      +'DTAN',1,F,F,T,F,F,F,F,F,
  3453.      +'DTANH',1,F,F,T,F,F,F,F,F,
  3454.      +'FLOAT',1,T,F,F,F,F,F,F,F,
  3455.      +'IABS',1,T,F,F,F,F,F,F,F,
  3456.      +'ICHAR',1,F,F,F,F,T,F,F,F,
  3457.      +'IDIM',2,T,F,F,F,F,F,F,F,
  3458.      +'IDINT',1,F,F,T,F,F,F,F,F,
  3459.      +'IDNINT',1,F,F,T,F,F,F,F,F,
  3460.      +'IFIX',1,F,T,F,F,F,F,F,F,
  3461.      +'INDEX',2,F,F,F,F,T,F,F,F,
  3462.      +'INT',1,T,T,T,T,F,T,T,T,
  3463.      +'ISIGN',2,T,F,F,F,F,F,F,F,
  3464.      +'LEN',1,F,F,F,F,T,F,F,F,
  3465.      +'LGE',2,F,F,F,F,T,F,F,F/
  3466.         DATA (INTNAM(J),NARGS(J),(VALID(J2,J),J2=1,8),J=58,NINTS)/
  3467.      +'LGT',2,F,F,F,F,T,F,F,F,
  3468.      +'LLE',2,F,F,F,F,T,F,F,F,
  3469.      +'LLT',2,F,F,F,F,T,F,F,F,
  3470.      +'MAX0',-2,T,F,F,F,F,F,F,F,
  3471.      +'MAX1',-2,F,T,F,F,F,F,F,F,
  3472.      +'MIN0',-2,T,F,F,F,F,F,F,F,
  3473.      +'MIN1',-2,F,T,F,F,F,F,F,F,
  3474.      +'NINT',1,F,T,T,F,F,F,F,T,
  3475.      +'REAL',1,T,T,T,T,F,T,T,T,
  3476.      +'SNGL',1,F,F,T,F,F,F,F,F/
  3477.  
  3478.         CALL ZYGTST(SYMBOL(2),TEXT)
  3479.         IF (LENGTH(TEXT).GT.6)
  3480.      +      CALL ERRMES('Intrinsic function name too long',-1001)
  3481.         CALL ZTOCAP(TEXT)
  3482.         CALL ZITOF(TEXT,1,6,NAME,.FALSE.)
  3483.         IF (ZIAND(SYMBOL(6),4096).EQ.0) THEN
  3484.             CALL ERRMES('Non-standard intrinsic '//NAME(:LENSTR(NAME))//
  3485.      +                  ' n'//'ot checked',-1002)
  3486.             RETURN
  3487.         END IF
  3488.         FUN=FIND(NAME,INTNAM,NINTS)
  3489.         IF (FUN.EQ.0) THEN
  3490. C Not found -- look in the generic intrinsic function list
  3491.             CALL EVFGEN(NODE,SYMBOL,STATUS)
  3492.             IF (STATUS.NE.-1) THEN
  3493.                  CALL ERRMES(
  3494.      +'Generic intrinsic function '//NAME(:LENGTH(TEXT))//
  3495.      +' explicitly typed',-1002)
  3496.             END IF
  3497.             RETURN
  3498.         END IF
  3499.         PTR=ZYDOWN(NODE)
  3500.         NAARGS=0
  3501.  
  3502.  100    PTR=ZYNEXT(PTR)
  3503.         IF (PTR.NE.0) THEN
  3504.             NAARGS=NAARGS+1
  3505.             ATYPE=TYPE(ZYXGDT(PTR))
  3506.             IF (ATYPE.EQ.0) THEN
  3507.                 CALL ERRMES('Invalid argument type to intrinsic '//NAME,
  3508.      +                      -1)
  3509.                 STATUS=-1
  3510.                 RETURN
  3511.             END IF
  3512.             IF (.NOT.VALID(ATYPE,FUN)) THEN
  3513.                 CALL ERRMES('Invalid argument type to intrinsic '//NAME,
  3514.      +                      -1)
  3515.                 STATUS=-1
  3516.                 RETURN
  3517.             END IF
  3518.             IF (ZIAND(ZYXGTB(PTR),4194304+8388608).NE.0) THEN
  3519.                 CALL ERRMES('Argument to intrinsic '//
  3520.      +                      NAME(:LENSTR(NAME))//
  3521.      +                      ' is array o'//'r procedure',-1)
  3522.                 STATUS=-1
  3523.                 RETURN
  3524.             END IF
  3525.             GOTO 100
  3526.         END IF
  3527.         IF (NAARGS.NE.NARGS(FUN) .AND. .NOT.
  3528.      +      (NARGS(FUN).EQ.-1 .AND. (NAARGS.EQ.1 .OR. NAARGS.EQ.2) .OR.
  3529.      +      NARGS(FUN).EQ.-2 .AND. NAARGS.GE.2)) THEN
  3530.             CALL ERRMES('Wrong nu'//'mber of arguments to intrinsic '//
  3531.      +                  NAME,-1)
  3532.             STATUS=-1
  3533.         END IF
  3534.  
  3535.         END
  3536. C ----------------------------------------------------------------------
  3537. C
  3538. C       E V F G E N   -   Evaluate generic intrinsic function reference
  3539. C
  3540.  
  3541.         SUBROUTINE EVFGEN(NODE,SYMBOL,STATUS)
  3542.         INTEGER NODE,SYMBOL(8),STATUS
  3543.  
  3544.         LOGICAL T,F
  3545.         INTEGER I,R,D,C,Z,S,Q
  3546.         PARAMETER (T=.TRUE.,F=.FALSE.,I=1,R=2,
  3547.      +             D=5,C=4,Z=7,
  3548.      +             S=14,Q=15)
  3549.  
  3550.         INTEGER NGENS
  3551.         PARAMETER (NGENS=22)
  3552.  
  3553.         CHARACTER*6 GENNAM(NGENS),NAME
  3554.         INTEGER NARGS(NGENS),RESULT(7,NGENS),TYPE(-3:15),J,J2,
  3555.      +          TEXT(134),FUN,NAARGS,ARGTYP,PTR
  3556.  
  3557.         SAVE
  3558.  
  3559.         INTEGER FIND
  3560.  
  3561.         INTEGER ZYDOWN,ZYNEXT,ZYXGDT,LENGTH,ZIAND,ZYXGTB
  3562.         EXTERNAL ZYDOWN,ZYNEXT,ZYXGDT,LENGTH,ZITOF,ZYXSDT,
  3563.      +           ZIAND,ZYXGTB
  3564.  
  3565.         DATA TYPE(1)/1/,
  3566.      +       TYPE(2)/2/,
  3567.      +       TYPE(5)/3/,
  3568.      +       TYPE(4)/4/,
  3569.      +       TYPE(7)/5/,
  3570.      +       TYPE(14)/6/,
  3571.      +       TYPE(15)/7/,
  3572.      +       TYPE(3),TYPE(-2),TYPE(-1),
  3573.      +       TYPE(10),TYPE(-3),TYPE(9),
  3574.      +       TYPE(11),TYPE(6),TYPE(12),
  3575.      +       TYPE(13)/10*0/
  3576.  
  3577. C Table:   Name  Nargs  Result type by arg type (0=illegal)
  3578. C ------                INT REAL DP COMPL DCMPLX INT*2 REAL*16
  3579.  
  3580.         DATA (GENNAM(J),NARGS(J),(RESULT(J2,J),J2=1,7),J=1,19)/
  3581.      +'ABS',1,I,R,D,R,D,S,Q,
  3582.      +'ACOS',1,0,R,D,0,0,0,Q,
  3583.      +'AINT',1,0,R,D,0,0,0,Q,
  3584.      +'ANINT',1,0,R,D,0,0,0,Q,
  3585.      +'ASIN',1,0,R,D,0,0,0,Q,
  3586.      +'ATAN',1,0,R,D,0,0,0,Q,
  3587.      +'ATAN2',2,0,R,D,0,0,0,Q,
  3588.      +'COS',1,0,R,D,C,Z,0,Q,
  3589.      +'COSH',1,0,R,D,0,0,0,Q,
  3590.      +'DIM',2,I,R,D,0,0,0,Q,
  3591.      +'EXP',1,0,R,D,C,Z,0,Q,
  3592.      +'LOG',1,0,R,D,C,Z,0,Q,
  3593.      +'LOG10',1,0,R,D,0,0,0,Q,
  3594.      +'MAX',-2,I,R,D,0,0,S,Q,
  3595.      +'MIN',-2,I,R,D,0,0,S,Q,
  3596.      +'MOD',2,I,R,D,0,0,S,Q,
  3597.      +'SIGN',2,I,R,D,0,0,S,Q,
  3598.      +'SIN',1,0,R,D,C,Z,0,Q,
  3599.      +'SINH',1,0,R,D,0,0,0,Q/
  3600.         DATA (GENNAM(J),NARGS(J),(RESULT(J2,J),J2=1,7),J=20,NGENS)/
  3601.      +'SQRT',1,0,R,D,C,Z,0,Q,
  3602.      +'TAN',1,0,R,D,0,0,0,Q,
  3603.      +'TANH',1,0,R,D,0,0,0,Q/
  3604.  
  3605.         CALL ZYGTST(SYMBOL(2),TEXT)
  3606.         IF (LENGTH(TEXT).GT.6)
  3607.      +      CALL ERRMES('Intrinsic name too long',-1001)
  3608.         CALL ZTOCAP(TEXT)
  3609.         CALL ZITOF(TEXT,1,6,NAME,.FALSE.)
  3610.         FUN=FIND(NAME,GENNAM,NGENS)
  3611.         IF (FUN.EQ.0) THEN
  3612.             CALL ERRMES('Couldn''t find intrinsic function "'//
  3613.      +                  NAME(:LENGTH(TEXT))//'"',-1)
  3614.             STATUS=-1
  3615.             RETURN
  3616.         END IF
  3617.         PTR=ZYDOWN(NODE)
  3618.         NAARGS=0
  3619.  
  3620.  100    PTR=ZYNEXT(PTR)
  3621.         IF (PTR.NE.0) THEN
  3622.             NAARGS=NAARGS+1
  3623.             IF (NAARGS.EQ.1) THEN
  3624.                 ARGTYP=TYPE(ZYXGDT(PTR))
  3625.                 IF (ARGTYP.EQ.0) THEN
  3626.                     CALL ERRMES('Incorrect argument type to intrinsic',
  3627.      +                          -1)
  3628.                     STATUS=-1
  3629.                     RETURN
  3630.                 END IF
  3631.             ELSE IF (ARGTYP.NE.TYPE(ZYXGDT(PTR))) THEN
  3632.                 CALL ERRMES('Inconsistent argument types to intrinsic',
  3633.      +                      -1)
  3634.             END IF
  3635.             IF (ZIAND(ZYXGTB(PTR),4194304+8388608).NE.0) THEN
  3636.                 CALL ERRMES('Intrinsic argument is array/procedure',
  3637.      +                      -1)
  3638.                 STATUS=-1
  3639.                 RETURN
  3640.             END IF
  3641.             GOTO 100
  3642.         END IF
  3643.         IF (NAARGS.NE.NARGS(FUN) .AND. .NOT.
  3644.      +      (NARGS(FUN).EQ.-2 .AND. NAARGS.GE.2 .OR.
  3645.      +      NARGS(FUN).EQ.-1 .AND. (NAARGS.EQ.1 .OR. NAARGS.EQ.2))) THEN
  3646.             CALL ERRMES('Wrong nu'//'mber of arguments to intrinsic',
  3647.      +                  -1)
  3648.             STATUS=-1
  3649. C Cannot have 0 arguments for an intrinsic, esp. a generic one ...
  3650.         ELSE IF (RESULT(ARGTYP,FUN).EQ.0) THEN
  3651.             CALL ERRMES('Incorrect argument types for intrinsic',-1)
  3652.             STATUS=-1
  3653.         ELSE IF (SYMBOL(4).EQ.8) THEN
  3654.             CALL ZYXSDT(NODE,RESULT(ARGTYP,FUN))
  3655.         ELSE IF (RESULT(ARGTYP,FUN).NE.SYMBOL(4)) THEN
  3656.             CALL ERRMES('Generic intrinsic function '//
  3657.      +                  NAME(:LENGTH(TEXT))//' incorrectly typed',-1)
  3658.             STATUS=-1
  3659.         END IF
  3660.  
  3661.         END
  3662. C ----------------------------------------------------------------------
  3663. C
  3664. C       E V F E X T   -   Evaluate an external function reference
  3665. C
  3666.  
  3667.         SUBROUTINE EVFEXT(NODE,SYMBOL,INSF,STATUS)
  3668.         INTEGER NODE,SYMBOL(8),STATUS
  3669.         LOGICAL INSF
  3670.  
  3671.         COMMON/DOSTK/DOLVL,DOLBL,DOIDX
  3672.         INTEGER DOLVL,DOLBL(25),DOIDX(25)
  3673.  
  3674.         COMMON/CONTXT/PUN,STMTNO
  3675.         INTEGER PUN,STMTNO
  3676.  
  3677.         INTEGER PTR,TMP,I,ARGNUM
  3678.  
  3679.         SAVE /CONTXT/,/DOSTK/
  3680.  
  3681.         INTEGER ZYXPAS,ZYNEXT,ZYDOWN,ZYNTYP
  3682.         EXTERNAL ZYXPAS,ZYNEXT,ZYDOWN,ZYNTYP,ZYXSUD
  3683.  
  3684.         IF (ZYXPAS(NODE,INSF,STMTNO).EQ.-1) THEN
  3685.             CALL ERRMES('Inconsistent argument lists',-1)
  3686.             STATUS=-1
  3687.         ELSE IF (DOLVL.GT.0) THEN
  3688.             PTR=ZYNEXT(ZYDOWN(NODE))
  3689.             ARGNUM=0
  3690.  100        IF (PTR.NE.0) THEN
  3691.                 TMP=-ZYDOWN(PTR)
  3692.                 ARGNUM=ARGNUM+1
  3693.                 DO 200 I=1,DOLVL
  3694.                     IF (TMP.EQ.DOIDX(I)) THEN
  3695.                         IF (ZYNTYP(PTR).EQ.108) THEN
  3696.                             CALL ZYXSUD(-ZYDOWN(ZYDOWN(NODE)),
  3697.      +                                        ARGNUM,STMTNO)
  3698.                         END IF
  3699.                     END IF
  3700.  200            CONTINUE
  3701.                 PTR=ZYNEXT(PTR)
  3702.                 GOTO 100
  3703.             END IF
  3704.         END IF
  3705.  
  3706.         END
  3707. C ----------------------------------------------------------------------
  3708. C
  3709. C       E V S F   -   Evaluate a statement function reference
  3710. C
  3711.  
  3712.         SUBROUTINE EVSF(NODE,SYMBOL,STATUS)
  3713.         INTEGER NODE,SYMBOL,STATUS
  3714.  
  3715.         INTEGER NARGS,ADTYPE(20),ACHLEN(20),PTR,I,ARGN
  3716.  
  3717.         LOGICAL BADP
  3718.  
  3719.         INTEGER ZYNEXT,ZYDOWN,ZYXGDT,ZYXGTB,ZIAND
  3720.         EXTERNAL ZYXGFA,ZYNEXT,ZYDOWN,ZYXGDT,ZYXGTB,ZIAND
  3721.  
  3722.         BADP(ARGN)=ZIAND(ZYXGTB(ARGN),4194304+8388608).NE.0
  3723.  
  3724.         PTR=ZYDOWN(NODE)
  3725.         CALL ZYXGFA(-ZYDOWN(PTR),NARGS,ADTYPE,ACHLEN)
  3726.         DO 100 I=1,NARGS
  3727.             PTR=ZYNEXT(PTR)
  3728.             IF (PTR.EQ.0) THEN
  3729.                 STATUS=-1
  3730.                 CALL ERRMES('Insufficient arguments to stmt fn',-1)
  3731.                 RETURN
  3732.             ELSE IF (ZYXGDT(PTR).NE.ADTYPE(I)) THEN
  3733.                 STATUS=-1
  3734.                 CALL ERRMES('Type mismatch in stmt fn reference',-1)
  3735.                 RETURN
  3736.             ELSE IF (BADP(PTR)) THEN
  3737.                 STATUS=-1
  3738.                 CALL ERRMES(
  3739.      +'Array o'//'r Procedure name in stmt fn reference',-1)
  3740.                 RETURN
  3741.             END IF
  3742.  100    CONTINUE
  3743.  
  3744.         END
  3745. C ----------------------------------------------------------------------
  3746. C
  3747. C       F I N D   -   Find a name in a sorted table (binary search)
  3748. C
  3749.  
  3750.         INTEGER FUNCTION FIND(NAME,TABLE,TSIZE)
  3751.         INTEGER TSIZE
  3752.         CHARACTER*(*) NAME,TABLE(TSIZE)
  3753.  
  3754.         INTEGER I,L,R
  3755.  
  3756.         INTRINSIC LLE
  3757.  
  3758.         L=1
  3759.         R=TSIZE
  3760.  
  3761.  100    I=(L+R)/2
  3762.         IF (LLE(NAME,TABLE(I))) THEN
  3763.             R=I
  3764.         ELSE
  3765.             L=I+1
  3766.         END IF
  3767.         IF (L.LT.R) GOTO 100
  3768.  
  3769.         IF (NAME.EQ.TABLE(L)) THEN
  3770.             FIND=L
  3771.         ELSE
  3772.             FIND=0
  3773.         END IF
  3774.  
  3775.         END
  3776. C ----------------------------------------------------------------------
  3777. C
  3778. C       C O M P A T   -   Say if two datatypes are compatible
  3779. C
  3780.  
  3781.         LOGICAL FUNCTION COMPAT(TYPE1,TYPE2)
  3782.         INTEGER TYPE1,TYPE2
  3783.  
  3784.         IF (TYPE1.EQ.6 .OR. TYPE2.EQ.6 .OR.
  3785.      +      TYPE1.EQ.9 .OR. TYPE2.EQ.9) THEN
  3786.             COMPAT=TYPE1.EQ.TYPE2
  3787. C Check that both sides of a logical assignment are logicals
  3788.         ELSE IF (TYPE1.EQ.3 .OR. TYPE1.EQ.12 .OR.
  3789.      +           TYPE1.EQ.13) THEN
  3790.             IF (TYPE2.EQ.3 .OR. TYPE2.EQ.12 .OR.
  3791.      +          TYPE2.EQ.13) THEN
  3792.                 COMPAT=.TRUE.
  3793.             ELSE
  3794.                 COMPAT=.FALSE.
  3795.             ENDIF
  3796.         ELSE IF (TYPE2.EQ.3 .OR. TYPE2.EQ.12 .OR.
  3797.      +           TYPE2.EQ.13) THEN
  3798.             COMPAT=.FALSE.
  3799.         ELSE
  3800.             COMPAT=.TRUE.
  3801.         END IF
  3802.  
  3803.         END
  3804. C ----------------------------------------------------------------------
  3805. C
  3806. C       G E T S U   -   Get storage unit of item within object
  3807. C
  3808.  
  3809.         INTEGER FUNCTION GETSU(ITEM)
  3810.         INTEGER ITEM
  3811.  
  3812.         INTEGER PTR,STATUS,TMP,ARGN
  3813.  
  3814.         INTEGER ZYDOWN,ZYNEXT,ZYNTYP,ZYXGVA,ZYXEAE,
  3815.      +          ZYXGDT,ZYXSU,ZYXGTB,ZIAND
  3816.         EXTERNAL ZYDOWN,ZYNEXT,ZYNTYP,ZYXGVA,ZYXEAE,
  3817.      +           ZYXGDT,ZYXSU,ZYXGTB,ZIAND
  3818.  
  3819.         LOGICAL CONSTP
  3820.  
  3821.         CONSTP(ARGN)=ZIAND(ZYXGTB(ARGN),2097152).NE.0
  3822.  
  3823.         GETSU=-1
  3824.         STATUS=-2
  3825.         CALL EXPR(ITEM,.FALSE.,0,STATUS)
  3826.         IF (STATUS.EQ.-1) RETURN
  3827.         IF (ZYNTYP(ITEM).EQ.108) THEN
  3828.             GETSU=1
  3829.             RETURN
  3830.         END IF
  3831.         IF (ZYNTYP(ITEM).EQ.103) THEN
  3832.             PTR=ZYDOWN(ZYNEXT(ZYDOWN(ITEM)))
  3833.             IF (ZYNTYP(PTR).EQ.106) THEN
  3834.                 GETSU=1
  3835.             ELSE IF (CONSTP(PTR)) THEN
  3836.                 GETSU=ZYXGVA(PTR)
  3837.             ELSE
  3838.                 GETSU=-1
  3839.                 CALL ERRMES('Subscript expression must be constant',
  3840.      +                      -1)
  3841.                 RETURN
  3842.             END IF
  3843.             PTR=ZYDOWN(ITEM)
  3844.         ELSE
  3845.             GETSU=1
  3846.             PTR=ITEM
  3847.         END IF
  3848.         IF (ZYNTYP(PTR).EQ.104) THEN
  3849.             TMP=ZYXEAE(PTR)
  3850.             IF (TMP.EQ.-1) THEN
  3851.                 CALL ERRMES('Invalid array element reference',-1)
  3852.                 GETSU=-1
  3853.                 RETURN
  3854.             END IF
  3855.             GETSU=TMP*ZYXSU(ZYXGDT(PTR))+GETSU
  3856.         END IF
  3857.  
  3858.         END
  3859. C ----------------------------------------------------------------------
  3860. C
  3861. C       C H K T Y P   -   Check type/byte length compatibility
  3862. C
  3863.  
  3864.         SUBROUTINE CHKTYP(NTYPE,BLEN)
  3865.         INTEGER NTYPE,BLEN
  3866.  
  3867.         IF (NTYPE.EQ.10 .AND. BLEN.NE.4 .AND.
  3868.      +      BLEN.NE.2*4 .AND. BLEN.NE.4*4 .OR.
  3869.      +      NTYPE.EQ.9 .AND. BLEN.NE.4 .AND.
  3870.      +      BLEN*2.NE.4 .OR.
  3871.      +      NTYPE.EQ.12 .AND. BLEN.NE.2*4 .AND.
  3872.      +      BLEN.NE.4*4 .OR.
  3873.      +      NTYPE.EQ.13 .AND. BLEN.NE.4 .AND.
  3874.      +      BLEN*2.NE.4 .AND. BLEN*4.NE.4)
  3875.      +      CALL ERRMES('Invalid byte length',-1)
  3876.  
  3877.         END
  3878. C ----------------------------------------------------------------------
  3879. C
  3880. C       S T R L E N   -   Return length of string w/out trailing blanks
  3881. C                         (returned length is always at least 1, so it
  3882. C                         can be used to select a substring w/out fear).
  3883. C
  3884.  
  3885.         INTEGER FUNCTION LENSTR(STRING)
  3886.         CHARACTER*(*) STRING
  3887.  
  3888.         INTRINSIC LEN
  3889.  
  3890.         LENSTR=LEN(STRING)
  3891.  100    IF (STRING(LENSTR:LENSTR).EQ.' ' .AND. LENSTR.GT.1) THEN
  3892.             LENSTR=LENSTR-1
  3893.             GOTO 100
  3894.         END IF
  3895.  
  3896.         END
  3897. C ----------------------------------------------------------------------
  3898. C
  3899. C       E R R S Y M   -   Display a symbol error message
  3900. C
  3901.  
  3902.         SUBROUTINE ERRSYM(STRING,SYMPTR,LEVEL)
  3903.         CHARACTER*(*) STRING
  3904.         INTEGER SYMPTR,LEVEL
  3905.  
  3906.         CHARACTER*134 MSG
  3907.         INTEGER SYMBOL(8),TEXT(134)
  3908.  
  3909.         INTEGER LENSTR
  3910.  
  3911.         EXTERNAL ZYGTSY,ZYGTST,ZITOF
  3912.  
  3913.         CALL ZYGTSY(SYMPTR,SYMBOL)
  3914.         CALL ZYGTST(SYMBOL(2),TEXT)
  3915.         MSG=STRING
  3916.         CALL ZITOF(TEXT,1,134-LEN(STRING),MSG(LEN(STRING)+1:),
  3917.      +             .TRUE.)
  3918.         CALL ERRMES(MSG(:LENSTR(MSG)),LEVEL)
  3919.  
  3920.         END
  3921. C ----------------------------------------------------------------------
  3922. C
  3923. C       E R R M E S   -   Display an error message
  3924. C
  3925.  
  3926.         SUBROUTINE ERRMES(STRING,LEVEL)
  3927.         CHARACTER*(*) STRING
  3928.         INTEGER LEVEL
  3929.  
  3930.         COMMON/ERRORC/NERROR,NWARN
  3931.         INTEGER NERROR,NWARN
  3932.  
  3933.         COMMON/CONTXT/PUN,STMTNO
  3934.         INTEGER PUN,STMTNO
  3935.  
  3936.         COMMON/PUNAMC/PUNAME
  3937.         CHARACTER*6 PUNAME
  3938.  
  3939.         SAVE /ERRORC/,/CONTXT/,/PUNAMC/
  3940.  
  3941.         EXTERNAL ZCHOUT,ZPTINT,PUTCH,ERROR
  3942.  
  3943.         IF (LEVEL.EQ.-1) THEN
  3944.             CALL ZCHOUT('Error: ',2)
  3945.             NERROR=NERROR+1
  3946.         ELSE IF (LEVEL.EQ.-1002) THEN
  3947.             CALL ZCHOUT('Warning: ',2)
  3948.             NWARN=NWARN+1
  3949.         ELSE IF (LEVEL.EQ.-1001) THEN
  3950.             CALL ZCHOUT('Fatal Error: ',2)
  3951.         ELSE IF (LEVEL.EQ.-2) THEN
  3952.             CALL ZCHOUT('Info: ',2)
  3953.         END IF
  3954.         CALL ZCHOUT(STRING,2)
  3955.         IF (STMTNO.GT.0) THEN
  3956.             CALL ZCHOUT(' at statement ',2)
  3957.             CALL ZPTINT(STMTNO,1,2)
  3958.         END IF
  3959.         CALL ZCHOUT(' in '//PUNAME,2)
  3960.         CALL PUTCH(10,2)
  3961.         IF (LEVEL.EQ.-1001)
  3962.      +      CALL ERROR('FATAL ERROR - ANALYSIS ABORTED')
  3963.  
  3964.         END
  3965. C ----------------------------------------------------------------------
  3966. C
  3967. C       U P D C O M   -   If variable is in common, mark the common as
  3968. C                         updated (this is for internal files)
  3969. C
  3970.  
  3971.         SUBROUTINE UPDCOM(VARPTR)
  3972.         INTEGER VARPTR
  3973.  
  3974.         COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
  3975.         INTEGER NSYMS,NPUS,PUIDX(250),
  3976.      +          SYMBOL(8,5003)
  3977.         LOGICAL MODFLG
  3978.  
  3979.         SAVE /XCSYMS/
  3980.         COMMON/XCATRX/SYMATR,ATRGLB
  3981.         INTEGER SYMATR(69000),ATRGLB
  3982.         SAVE /XCATRX/
  3983.  
  3984.         INTEGER COMPTR
  3985.  
  3986.         INTEGER ZIOR
  3987.         EXTERNAL ZIOR
  3988.  
  3989.         COMPTR=SYMATR(SYMBOL(8,VARPTR)+1)
  3990.  
  3991.         IF (COMPTR.NE.0) THEN
  3992.             SYMATR(SYMBOL(7,COMPTR))=
  3993.      +          ZIOR(SYMATR(SYMBOL(7,COMPTR)),32)
  3994.         END IF
  3995.  
  3996.         END
  3997.